home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / pp_sys.c < prev    next >
C/C++ Source or Header  |  1998-07-21  |  91KB  |  4,591 lines
  1. /*    pp_sys.c
  2.  *
  3.  *    Copyright (c) 1991-1997, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  */
  9.  
  10. /*
  11.  * But only a short way ahead its floor and the walls on either side were
  12.  * cloven by a great fissure, out of which the red glare came, now leaping
  13.  * up, now dying down into darkness; and all the while far below there was
  14.  * a rumour and a trouble as of great engines throbbing and labouring.
  15.  */
  16.  
  17. #include "EXTERN.h"
  18. #include "perl.h"
  19.  
  20. /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  21. #ifdef I_UNISTD
  22. # include <unistd.h>
  23. #endif
  24.  
  25. #ifdef HAS_SYSCALL   
  26. #ifdef __cplusplus              
  27. extern "C" int syscall(unsigned long,...);
  28. #endif
  29. #endif
  30.  
  31. #ifdef I_SYS_WAIT
  32. # include <sys/wait.h>
  33. #endif
  34.  
  35. #ifdef I_SYS_RESOURCE
  36. # include <sys/resource.h>
  37. #endif
  38.  
  39. #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
  40. # include <sys/socket.h>
  41. # ifdef I_NETDB
  42. #  include <netdb.h>
  43. # endif
  44. # ifndef ENOTSOCK
  45. #  ifdef I_NET_ERRNO
  46. #   include <net/errno.h>
  47. #  endif
  48. # endif
  49. #endif
  50.  
  51. #ifdef HAS_SELECT
  52. #ifdef I_SYS_SELECT
  53. #include <sys/select.h>
  54. #endif
  55. #endif
  56.  
  57. /* XXX Configure test needed.
  58.    h_errno might not be a simple 'int', especially for multi-threaded
  59.    applications.  HOST_NOT_FOUND is typically defined in <netdb.h>.
  60. */
  61. #if defined(HOST_NOT_FOUND) && !defined(h_errno)
  62. extern int h_errno;
  63. #endif
  64.  
  65. #ifdef HAS_PASSWD
  66. # ifdef I_PWD
  67. #  include <pwd.h>
  68. # else
  69.     struct passwd *getpwnam _((char *));
  70.     struct passwd *getpwuid _((Uid_t));
  71. # endif
  72. # ifdef HAS_GETPWENT
  73.   struct passwd *getpwent _((void));
  74. # endif
  75. #endif
  76.  
  77. #ifdef HAS_GROUP
  78. # ifdef I_GRP
  79. #  include <grp.h>
  80. # else
  81.     struct group *getgrnam _((char *));
  82.     struct group *getgrgid _((Gid_t));
  83. # endif
  84. # ifdef HAS_GETGRENT
  85.     struct group *getgrent _((void));
  86. # endif
  87. #endif
  88.  
  89. #ifdef I_UTIME
  90. #  if defined(_MSC_VER) || defined(__MINGW32__)
  91. #    include <sys/utime.h>
  92. #  else
  93. #    include <utime.h>
  94. #  endif
  95. #endif
  96. #ifdef I_FCNTL
  97. #include <fcntl.h>
  98. #endif
  99. #ifdef I_SYS_FILE
  100. #include <sys/file.h>
  101. #endif
  102.  
  103. /* Put this after #includes because fork and vfork prototypes may conflict. */
  104. #ifndef HAS_VFORK
  105. #   define vfork fork
  106. #endif
  107.  
  108. /* Put this after #includes because <unistd.h> defines _XOPEN_*. */
  109. #ifndef Sock_size_t
  110. #  if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
  111. #    define Sock_size_t Size_t
  112. #  else
  113. #    define Sock_size_t int
  114. #  endif
  115. #endif
  116.  
  117. #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
  118. static int dooneliner _((char *cmd, char *filename));
  119. #endif
  120.  
  121. #ifdef HAS_CHSIZE
  122. # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
  123. #   undef my_chsize
  124. # endif
  125. # define my_chsize PerlLIO_chsize
  126. #endif
  127.  
  128. #ifdef HAS_FLOCK
  129. #  define FLOCK flock
  130. #else /* no flock() */
  131.  
  132.    /* fcntl.h might not have been included, even if it exists, because
  133.       the current Configure only sets I_FCNTL if it's needed to pick up
  134.       the *_OK constants.  Make sure it has been included before testing
  135.       the fcntl() locking constants. */
  136. #  if defined(HAS_FCNTL) && !defined(I_FCNTL)
  137. #    include <fcntl.h>
  138. #  endif
  139.  
  140. #  if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
  141. #    define FLOCK fcntl_emulate_flock
  142. #    define FCNTL_EMULATE_FLOCK
  143. #  else /* no flock() or fcntl(F_SETLK,...) */
  144. #    ifdef HAS_LOCKF
  145. #      define FLOCK lockf_emulate_flock
  146. #      define LOCKF_EMULATE_FLOCK
  147. #    endif /* lockf */
  148. #  endif /* no flock() or fcntl(F_SETLK,...) */
  149.  
  150. #  ifdef FLOCK
  151.      static int FLOCK _((int, int));
  152.  
  153.     /*
  154.      * These are the flock() constants.  Since this sytems doesn't have
  155.      * flock(), the values of the constants are probably not available.
  156.      */
  157. #    ifndef LOCK_SH
  158. #      define LOCK_SH 1
  159. #    endif
  160. #    ifndef LOCK_EX
  161. #      define LOCK_EX 2
  162. #    endif
  163. #    ifndef LOCK_NB
  164. #      define LOCK_NB 4
  165. #    endif
  166. #    ifndef LOCK_UN
  167. #      define LOCK_UN 8
  168. #    endif
  169. #  endif /* emulating flock() */
  170.  
  171. #endif /* no flock() */
  172.  
  173. #ifndef MAXPATHLEN
  174. #  ifdef PATH_MAX
  175. #    define MAXPATHLEN PATH_MAX
  176. #  else
  177. #    define MAXPATHLEN 1024
  178. #  endif
  179. #endif
  180.  
  181. #define ZBTLEN 10
  182. static char zero_but_true[ZBTLEN + 1] = "0 but true";
  183.  
  184. /* Pushy I/O. */
  185.  
  186. PP(pp_backtick)
  187. {
  188.     djSP; dTARGET;
  189.     PerlIO *fp;
  190.     char *tmps = POPp;
  191.     I32 gimme = GIMME_V;
  192.  
  193.     TAINT_PROPER("``");
  194.     fp = PerlProc_popen(tmps, "r");
  195.     if (fp) {
  196.     if (gimme == G_VOID) {
  197.         char tmpbuf[256];
  198.         while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
  199.         /*SUPPRESS 530*/
  200.         ;
  201.     }
  202.     else if (gimme == G_SCALAR) {
  203.         sv_setpv(TARG, "");    /* note that this preserves previous buffer */
  204.         while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
  205.         /*SUPPRESS 530*/
  206.         ;
  207.         XPUSHs(TARG);
  208.         SvTAINTED_on(TARG);
  209.     }
  210.     else {
  211.         SV *sv;
  212.  
  213.         for (;;) {
  214.         sv = NEWSV(56, 79);
  215.         if (sv_gets(sv, fp, 0) == Nullch) {
  216.             SvREFCNT_dec(sv);
  217.             break;
  218.         }
  219.         XPUSHs(sv_2mortal(sv));
  220.         if (SvLEN(sv) - SvCUR(sv) > 20) {
  221.             SvLEN_set(sv, SvCUR(sv)+1);
  222.             Renew(SvPVX(sv), SvLEN(sv), char);
  223.         }
  224.         SvTAINTED_on(sv);
  225.         }
  226.     }
  227.     STATUS_NATIVE_SET(PerlProc_pclose(fp));
  228.     TAINT;        /* "I believe that this is not gratuitous!" */
  229.     }
  230.     else {
  231.     STATUS_NATIVE_SET(-1);
  232.     if (gimme == G_SCALAR)
  233.         RETPUSHUNDEF;
  234.     }
  235.  
  236.     RETURN;
  237. }
  238.  
  239. PP(pp_glob)
  240. {
  241.     OP *result;
  242.     ENTER;
  243.  
  244. #ifndef VMS
  245.     if (PL_tainting) {
  246.     /*
  247.      * The external globbing program may use things we can't control,
  248.      * so for security reasons we must assume the worst.
  249.      */
  250.     TAINT;
  251.     taint_proper(no_security, "glob");
  252.     }
  253. #endif /* !VMS */
  254.  
  255.     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
  256.     PL_last_in_gv = (GV*)*PL_stack_sp--;
  257.  
  258.     SAVESPTR(PL_rs);        /* This is not permanent, either. */
  259.     PL_rs = sv_2mortal(newSVpv("", 1));
  260. #ifndef DOSISH
  261. #ifndef CSH
  262.     *SvPVX(PL_rs) = '\n';
  263. #endif    /* !CSH */
  264. #endif    /* !DOSISH */
  265.  
  266.     result = do_readline();
  267.     LEAVE;
  268.     return result;
  269. }
  270.  
  271. #if 0        /* XXX never used! */
  272. PP(pp_indread)
  273. {
  274.     PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), PL_na), TRUE,SVt_PVIO);
  275.     return do_readline();
  276. }
  277. #endif
  278.  
  279. PP(pp_rcatline)
  280. {
  281.     PL_last_in_gv = cGVOP->op_gv;
  282.     return do_readline();
  283. }
  284.  
  285. PP(pp_warn)
  286. {
  287.     djSP; dMARK;
  288.     char *tmps;
  289.     if (SP - MARK != 1) {
  290.     dTARGET;
  291.     do_join(TARG, &PL_sv_no, MARK, SP);
  292.     tmps = SvPV(TARG, PL_na);
  293.     SP = MARK + 1;
  294.     }
  295.     else {
  296.     tmps = SvPV(TOPs, PL_na);
  297.     }
  298.     if (!tmps || !*tmps) {
  299.       SV *error = ERRSV;
  300.     (void)SvUPGRADE(error, SVt_PV);
  301.     if (SvPOK(error) && SvCUR(error))
  302.         sv_catpv(error, "\t...caught");
  303.     tmps = SvPV(error, PL_na);
  304.     }
  305.     if (!tmps || !*tmps)
  306.     tmps = "Warning: something's wrong";
  307.     warn("%s", tmps);
  308.     RETSETYES;
  309. }
  310.  
  311. PP(pp_die)
  312. {
  313.     djSP; dMARK;
  314.     char *tmps;
  315.     SV *tmpsv = Nullsv;
  316.     char *pat = "%s";
  317.     if (SP - MARK != 1) {
  318.     dTARGET;
  319.     do_join(TARG, &PL_sv_no, MARK, SP);
  320.     tmps = SvPV(TARG, PL_na);
  321.     SP = MARK + 1;
  322.     }
  323.     else {
  324.     tmpsv = TOPs;
  325.     tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, PL_na);
  326.     }
  327.     if (!tmps || !*tmps) {
  328.       SV *error = ERRSV;
  329.     (void)SvUPGRADE(error, SVt_PV);
  330.     if(tmpsv ? SvROK(tmpsv) : SvROK(error)) {
  331.         if(tmpsv)
  332.         SvSetSV(error,tmpsv);
  333.         else if(sv_isobject(error)) {
  334.         HV *stash = SvSTASH(SvRV(error));
  335.         GV *gv = gv_fetchmethod(stash, "PROPAGATE");
  336.         if (gv) {
  337.             SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
  338.             SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
  339.             EXTEND(SP, 3);
  340.             PUSHMARK(SP);
  341.             PUSHs(error);
  342.             PUSHs(file);
  343.              PUSHs(line);
  344.             PUTBACK;
  345.             perl_call_sv((SV*)GvCV(gv),
  346.                  G_SCALAR|G_EVAL|G_KEEPERR);
  347.             sv_setsv(error,*PL_stack_sp--);
  348.         }
  349.         }
  350.         pat = Nullch;
  351.     }
  352.     else {
  353.         if (SvPOK(error) && SvCUR(error))
  354.         sv_catpv(error, "\t...propagated");
  355.         tmps = SvPV(error, PL_na);
  356.     }
  357.     }
  358.     if (!tmps || !*tmps)
  359.     tmps = "Died";
  360.     DIE(pat, tmps);
  361. }
  362.  
  363. /* I/O. */
  364.  
  365. PP(pp_open)
  366. {
  367.     djSP; dTARGET;
  368.     GV *gv;
  369.     SV *sv;
  370.     char *tmps;
  371.     STRLEN len;
  372.  
  373.     if (MAXARG > 1)
  374.     sv = POPs;
  375.     if (!isGV(TOPs))
  376.     DIE(no_usym, "filehandle");
  377.     if (MAXARG <= 1)
  378.     sv = GvSV(TOPs);
  379.     gv = (GV*)POPs;
  380.     if (!isGV(gv))
  381.     DIE(no_usym, "filehandle");
  382.     if (GvIOp(gv))
  383.     IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
  384.     tmps = SvPV(sv, len);
  385.     if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
  386.     PUSHi( (I32)PL_forkprocess );
  387.     else if (PL_forkprocess == 0)        /* we are a new child */
  388.     PUSHi(0);
  389.     else
  390.     RETPUSHUNDEF;
  391.     RETURN;
  392. }
  393.  
  394. PP(pp_close)
  395. {
  396.     djSP;
  397.     GV *gv;
  398.     MAGIC *mg;
  399.  
  400.     if (MAXARG == 0)
  401.     gv = PL_defoutgv;
  402.     else
  403.     gv = (GV*)POPs;
  404.  
  405.     if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
  406.     PUSHMARK(SP);
  407.     XPUSHs(mg->mg_obj);
  408.     PUTBACK;
  409.     ENTER;
  410.     perl_call_method("CLOSE", G_SCALAR);
  411.     LEAVE;
  412.     SPAGAIN;
  413.     RETURN;
  414.     }
  415.     EXTEND(SP, 1);
  416.     PUSHs(boolSV(do_close(gv, TRUE)));
  417.     RETURN;
  418. }
  419.  
  420. PP(pp_pipe_op)
  421. {
  422.     djSP;
  423. #ifdef HAS_PIPE
  424.     GV *rgv;
  425.     GV *wgv;
  426.     register IO *rstio;
  427.     register IO *wstio;
  428.     int fd[2];
  429.  
  430.     wgv = (GV*)POPs;
  431.     rgv = (GV*)POPs;
  432.  
  433.     if (!rgv || !wgv)
  434.     goto badexit;
  435.  
  436.     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
  437.     DIE(no_usym, "filehandle");
  438.     rstio = GvIOn(rgv);
  439.     wstio = GvIOn(wgv);
  440.  
  441.     if (IoIFP(rstio))
  442.     do_close(rgv, FALSE);
  443.     if (IoIFP(wstio))
  444.     do_close(wgv, FALSE);
  445.  
  446.     if (PerlProc_pipe(fd) < 0)
  447.     goto badexit;
  448.  
  449.     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
  450.     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
  451.     IoIFP(wstio) = IoOFP(wstio);
  452.     IoTYPE(rstio) = '<';
  453.     IoTYPE(wstio) = '>';
  454.  
  455.     if (!IoIFP(rstio) || !IoOFP(wstio)) {
  456.     if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
  457.     else PerlLIO_close(fd[0]);
  458.     if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
  459.     else PerlLIO_close(fd[1]);
  460.     goto badexit;
  461.     }
  462.  
  463.     RETPUSHYES;
  464.  
  465. badexit:
  466.     RETPUSHUNDEF;
  467. #else
  468.     DIE(no_func, "pipe");
  469. #endif
  470. }
  471.  
  472. PP(pp_fileno)
  473. {
  474.     djSP; dTARGET;
  475.     GV *gv;
  476.     IO *io;
  477.     PerlIO *fp;
  478.     if (MAXARG < 1)
  479.     RETPUSHUNDEF;
  480.     gv = (GV*)POPs;
  481.     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
  482.     RETPUSHUNDEF;
  483.     PUSHi(PerlIO_fileno(fp));
  484.     RETURN;
  485. }
  486.  
  487. PP(pp_umask)
  488. {
  489.     djSP; dTARGET;
  490.     int anum;
  491.  
  492. #ifdef HAS_UMASK
  493.     if (MAXARG < 1) {
  494.     anum = PerlLIO_umask(0);
  495.     (void)PerlLIO_umask(anum);
  496.     }
  497.     else
  498.     anum = PerlLIO_umask(POPi);
  499.     TAINT_PROPER("umask");
  500.     XPUSHi(anum);
  501. #else
  502.     /* Only DIE if trying to restrict permissions on `user' (self).
  503.      * Otherwise it's harmless and more useful to just return undef
  504.      * since 'group' and 'other' concepts probably don't exist here. */
  505.     if (MAXARG >= 1 && (POPi & 0700))
  506.     DIE("umask not implemented");
  507.     XPUSHs(&PL_sv_undef);
  508. #endif
  509.     RETURN;
  510. }
  511.  
  512. PP(pp_binmode)
  513. {
  514.     djSP;
  515.     GV *gv;
  516.     IO *io;
  517.     PerlIO *fp;
  518.  
  519.     if (MAXARG < 1)
  520.     RETPUSHUNDEF;
  521.  
  522.     gv = (GV*)POPs;
  523.  
  524.     EXTEND(SP, 1);
  525.     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
  526.     RETPUSHUNDEF;
  527.  
  528.     if (do_binmode(fp,IoTYPE(io),TRUE)) 
  529.     RETPUSHYES;
  530.     else
  531.     RETPUSHUNDEF;
  532. }
  533.  
  534.  
  535. PP(pp_tie)
  536. {
  537.     djSP;
  538.     dMARK;
  539.     SV *varsv;
  540.     HV* stash;
  541.     GV *gv;
  542.     SV *sv;
  543.     I32 markoff = MARK - PL_stack_base;
  544.     char *methname;
  545.     int how = 'P';
  546.     U32 items;
  547.  
  548.     varsv = *++MARK;
  549.     switch(SvTYPE(varsv)) {
  550.     case SVt_PVHV:
  551.         methname = "TIEHASH";
  552.         break;
  553.     case SVt_PVAV:
  554.         methname = "TIEARRAY";
  555.         break;
  556.     case SVt_PVGV:
  557.         methname = "TIEHANDLE";
  558.         how = 'q';
  559.         break;
  560.     default:
  561.         methname = "TIESCALAR";
  562.         how = 'q';
  563.         break;
  564.     }
  565.     items = SP - MARK++;
  566.     if (sv_isobject(*MARK)) {
  567.     ENTER;
  568.     PUSHSTACKi(PERLSI_MAGIC);
  569.     PUSHMARK(SP);
  570.     EXTEND(SP,items);
  571.     while (items--)
  572.         PUSHs(*MARK++);
  573.     PUTBACK;
  574.     perl_call_method(methname, G_SCALAR);
  575.     } 
  576.     else {
  577.     /* Not clear why we don't call perl_call_method here too.
  578.      * perhaps to get different error message ?
  579.      */
  580.     stash = gv_stashsv(*MARK, FALSE);
  581.     if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
  582.         DIE("Can't locate object method \"%s\" via package \"%s\"",
  583.          methname, SvPV(*MARK,PL_na));                   
  584.     }
  585.     ENTER;
  586.     PUSHSTACKi(PERLSI_MAGIC);
  587.     PUSHMARK(SP);
  588.     EXTEND(SP,items);
  589.     while (items--)
  590.         PUSHs(*MARK++);
  591.     PUTBACK;
  592.     perl_call_sv((SV*)GvCV(gv), G_SCALAR);
  593.     }
  594.     SPAGAIN;
  595.  
  596.     sv = TOPs;
  597.     POPSTACK;
  598.     if (sv_isobject(sv)) {
  599.     sv_unmagic(varsv, how);            
  600.     sv_magic(varsv, sv, how, Nullch, 0);
  601.     }
  602.     LEAVE;
  603.     SP = PL_stack_base + markoff;
  604.     PUSHs(sv);
  605.     RETURN;
  606. }
  607.  
  608. PP(pp_untie)
  609. {
  610.     djSP;
  611.     SV * sv ;
  612.  
  613.     sv = POPs;
  614.  
  615.     if (PL_dowarn) {
  616.         MAGIC * mg ;
  617.         if (SvMAGICAL(sv)) {
  618.             if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
  619.                 mg = mg_find(sv, 'P') ;
  620.             else
  621.                 mg = mg_find(sv, 'q') ;
  622.     
  623.             if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)  
  624.         warn("untie attempted while %lu inner references still exist",
  625.             (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
  626.         }
  627.     }
  628.  
  629.     if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
  630.     sv_unmagic(sv, 'P');
  631.     else
  632.     sv_unmagic(sv, 'q');
  633.     RETPUSHYES;
  634. }
  635.  
  636. PP(pp_tied)
  637. {
  638.     djSP;
  639.     SV * sv ;
  640.     MAGIC * mg ;
  641.  
  642.     sv = POPs;
  643.     if (SvMAGICAL(sv)) {
  644.         if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
  645.             mg = mg_find(sv, 'P') ;
  646.         else
  647.             mg = mg_find(sv, 'q') ;
  648.  
  649.         if (mg)  {
  650.             PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ; 
  651.             RETURN ;
  652.     }
  653.     }
  654.     RETPUSHUNDEF;
  655. }
  656.  
  657. PP(pp_dbmopen)
  658. {
  659.     djSP;
  660.     HV *hv;
  661.     dPOPPOPssrl;
  662.     HV* stash;
  663.     GV *gv;
  664.     SV *sv;
  665.  
  666.     hv = (HV*)POPs;
  667.  
  668.     sv = sv_mortalcopy(&PL_sv_no);
  669.     sv_setpv(sv, "AnyDBM_File");
  670.     stash = gv_stashsv(sv, FALSE);
  671.     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
  672.     PUTBACK;
  673.     perl_require_pv("AnyDBM_File.pm");
  674.     SPAGAIN;
  675.     if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
  676.         DIE("No dbm on this machine");
  677.     }
  678.  
  679.     ENTER;
  680.     PUSHMARK(SP);
  681.  
  682.     EXTEND(SP, 5);
  683.     PUSHs(sv);
  684.     PUSHs(left);
  685.     if (SvIV(right))
  686.     PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
  687.     else
  688.     PUSHs(sv_2mortal(newSViv(O_RDWR)));
  689.     PUSHs(right);
  690.     PUTBACK;
  691.     perl_call_sv((SV*)GvCV(gv), G_SCALAR);
  692.     SPAGAIN;
  693.  
  694.     if (!sv_isobject(TOPs)) {
  695.     SP--;
  696.     PUSHMARK(SP);
  697.     PUSHs(sv);
  698.     PUSHs(left);
  699.     PUSHs(sv_2mortal(newSViv(O_RDONLY)));
  700.     PUSHs(right);
  701.     PUTBACK;
  702.     perl_call_sv((SV*)GvCV(gv), G_SCALAR);
  703.     SPAGAIN;
  704.     }
  705.  
  706.     if (sv_isobject(TOPs)) {
  707.     sv_unmagic((SV *) hv, 'P');            
  708.     sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
  709.     }
  710.     LEAVE;
  711.     RETURN;
  712. }
  713.  
  714. PP(pp_dbmclose)
  715. {
  716.     return pp_untie(ARGS);
  717. }
  718.  
  719. PP(pp_sselect)
  720. {
  721.     djSP; dTARGET;
  722. #ifdef HAS_SELECT
  723.     register I32 i;
  724.     register I32 j;
  725.     register char *s;
  726.     register SV *sv;
  727.     double value;
  728.     I32 maxlen = 0;
  729.     I32 nfound;
  730.     struct timeval timebuf;
  731.     struct timeval *tbuf = &timebuf;
  732.     I32 growsize;
  733.     char *fd_sets[4];
  734. #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
  735.     I32 masksize;
  736.     I32 offset;
  737.     I32 k;
  738.  
  739. #   if BYTEORDER & 0xf0000
  740. #    define ORDERBYTE (0x88888888 - BYTEORDER)
  741. #   else
  742. #    define ORDERBYTE (0x4444 - BYTEORDER)
  743. #   endif
  744.  
  745. #endif
  746.  
  747.     SP -= 4;
  748.     for (i = 1; i <= 3; i++) {
  749.     if (!SvPOK(SP[i]))
  750.         continue;
  751.     j = SvCUR(SP[i]);
  752.     if (maxlen < j)
  753.         maxlen = j;
  754.     }
  755.  
  756. #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
  757. /* XXX Configure test needed. */
  758. #if defined(__linux__) || defined(OS2) || defined(NeXT) || defined(__osf__)
  759.     growsize = sizeof(fd_set);
  760. #else
  761.     growsize = maxlen;        /* little endians can use vecs directly */
  762. #endif
  763. #else
  764. #ifdef NFDBITS
  765.  
  766. #ifndef NBBY
  767. #define NBBY 8
  768. #endif
  769.  
  770.     masksize = NFDBITS / NBBY;
  771. #else
  772.     masksize = sizeof(long);    /* documented int, everyone seems to use long */
  773. #endif
  774.     growsize = maxlen + (masksize - (maxlen % masksize));
  775.     Zero(&fd_sets[0], 4, char*);
  776. #endif
  777.  
  778.     sv = SP[4];
  779.     if (SvOK(sv)) {
  780.     value = SvNV(sv);
  781.     if (value < 0.0)
  782.         value = 0.0;
  783.     timebuf.tv_sec = (long)value;
  784.     value -= (double)timebuf.tv_sec;
  785.     timebuf.tv_usec = (long)(value * 1000000.0);
  786.     }
  787.     else
  788.     tbuf = Null(struct timeval*);
  789.  
  790.     for (i = 1; i <= 3; i++) {
  791.     sv = SP[i];
  792.     if (!SvOK(sv)) {
  793.         fd_sets[i] = 0;
  794.         continue;
  795.     }
  796.     else if (!SvPOK(sv))
  797.         SvPV_force(sv,PL_na);    /* force string conversion */
  798.     j = SvLEN(sv);
  799.     if (j < growsize) {
  800.         Sv_Grow(sv, growsize);
  801.     }
  802.     j = SvCUR(sv);
  803.     s = SvPVX(sv) + j;
  804.     while (++j <= growsize) {
  805.         *s++ = '\0';
  806.     }
  807.  
  808. #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
  809.     s = SvPVX(sv);
  810.     New(403, fd_sets[i], growsize, char);
  811.     for (offset = 0; offset < growsize; offset += masksize) {
  812.         for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
  813.         fd_sets[i][j+offset] = s[(k % masksize) + offset];
  814.     }
  815. #else
  816.     fd_sets[i] = SvPVX(sv);
  817. #endif
  818.     }
  819.  
  820.     nfound = PerlSock_select(
  821.     maxlen * 8,
  822.     (Select_fd_set_t) fd_sets[1],
  823.     (Select_fd_set_t) fd_sets[2],
  824.     (Select_fd_set_t) fd_sets[3],
  825.     tbuf);
  826.     for (i = 1; i <= 3; i++) {
  827.     if (fd_sets[i]) {
  828.         sv = SP[i];
  829. #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
  830.         s = SvPVX(sv);
  831.         for (offset = 0; offset < growsize; offset += masksize) {
  832.         for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
  833.             s[(k % masksize) + offset] = fd_sets[i][j+offset];
  834.         }
  835.         Safefree(fd_sets[i]);
  836. #endif
  837.         SvSETMAGIC(sv);
  838.     }
  839.     }
  840.  
  841.     PUSHi(nfound);
  842.     if (GIMME == G_ARRAY && tbuf) {
  843.     value = (double)(timebuf.tv_sec) +
  844.         (double)(timebuf.tv_usec) / 1000000.0;
  845.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  846.     sv_setnv(sv, value);
  847.     }
  848.     RETURN;
  849. #else
  850.     DIE("select not implemented");
  851. #endif
  852. }
  853.  
  854. void
  855. setdefout(GV *gv)
  856. {
  857.     dTHR;
  858.     if (gv)
  859.     (void)SvREFCNT_inc(gv);
  860.     if (PL_defoutgv)
  861.     SvREFCNT_dec(PL_defoutgv);
  862.     PL_defoutgv = gv;
  863. }
  864.  
  865. PP(pp_select)
  866. {
  867.     djSP; dTARGET;
  868.     GV *newdefout, *egv;
  869.     HV *hv;
  870.  
  871.     newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
  872.  
  873.     egv = GvEGV(PL_defoutgv);
  874.     if (!egv)
  875.     egv = PL_defoutgv;
  876.     hv = GvSTASH(egv);
  877.     if (! hv)
  878.     XPUSHs(&PL_sv_undef);
  879.     else {
  880.     GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
  881.     if (gvp && *gvp == egv) {
  882.         gv_efullname3(TARG, PL_defoutgv, Nullch);
  883.         XPUSHTARG;
  884.     }
  885.     else {
  886.         XPUSHs(sv_2mortal(newRV((SV*)egv)));
  887.     }
  888.     }
  889.  
  890.     if (newdefout) {
  891.     if (!GvIO(newdefout))
  892.         gv_IOadd(newdefout);
  893.     setdefout(newdefout);
  894.     }
  895.  
  896.     RETURN;
  897. }
  898.  
  899. PP(pp_getc)
  900. {
  901.     djSP; dTARGET;
  902.     GV *gv;
  903.     MAGIC *mg;
  904.  
  905.     if (MAXARG <= 0)
  906.     gv = PL_stdingv;
  907.     else
  908.     gv = (GV*)POPs;
  909.     if (!gv)
  910.     gv = PL_argvgv;
  911.  
  912.     if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
  913.     I32 gimme = GIMME_V;
  914.     PUSHMARK(SP);
  915.     XPUSHs(mg->mg_obj);
  916.     PUTBACK;
  917.     ENTER;
  918.     perl_call_method("GETC", gimme);
  919.     LEAVE;
  920.     SPAGAIN;
  921.     if (gimme == G_SCALAR)
  922.         SvSetMagicSV_nosteal(TARG, TOPs);
  923.     RETURN;
  924.     }
  925.     if (!gv || do_eof(gv)) /* make sure we have fp with something */
  926.     RETPUSHUNDEF;
  927.     TAINT;
  928.     sv_setpv(TARG, " ");
  929.     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
  930.     PUSHTARG;
  931.     RETURN;
  932. }
  933.  
  934. PP(pp_read)
  935. {
  936.     return pp_sysread(ARGS);
  937. }
  938.  
  939. STATIC OP *
  940. doform(CV *cv, GV *gv, OP *retop)
  941. {
  942.     dTHR;
  943.     register PERL_CONTEXT *cx;
  944.     I32 gimme = GIMME_V;
  945.     AV* padlist = CvPADLIST(cv);
  946.     SV** svp = AvARRAY(padlist);
  947.  
  948.     ENTER;
  949.     SAVETMPS;
  950.  
  951.     push_return(retop);
  952.     PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
  953.     PUSHFORMAT(cx);
  954.     SAVESPTR(PL_curpad);
  955.     PL_curpad = AvARRAY((AV*)svp[1]);
  956.  
  957.     setdefout(gv);        /* locally select filehandle so $% et al work */
  958.     return CvSTART(cv);
  959. }
  960.  
  961. PP(pp_enterwrite)
  962. {
  963.     djSP;
  964.     register GV *gv;
  965.     register IO *io;
  966.     GV *fgv;
  967.     CV *cv;
  968.  
  969.     if (MAXARG == 0)
  970.     gv = PL_defoutgv;
  971.     else {
  972.     gv = (GV*)POPs;
  973.     if (!gv)
  974.         gv = PL_defoutgv;
  975.     }
  976.     EXTEND(SP, 1);
  977.     io = GvIO(gv);
  978.     if (!io) {
  979.     RETPUSHNO;
  980.     }
  981.     if (IoFMT_GV(io))
  982.     fgv = IoFMT_GV(io);
  983.     else
  984.     fgv = gv;
  985.  
  986.     cv = GvFORM(fgv);
  987.     if (!cv) {
  988.     if (fgv) {
  989.         SV *tmpsv = sv_newmortal();
  990.         gv_efullname3(tmpsv, fgv, Nullch);
  991.         DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
  992.     }
  993.     DIE("Not a format reference");
  994.     }
  995.     if (CvCLONE(cv))
  996.     cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
  997.  
  998.     IoFLAGS(io) &= ~IOf_DIDTOP;
  999.     return doform(cv,gv,PL_op->op_next);
  1000. }
  1001.  
  1002. PP(pp_leavewrite)
  1003. {
  1004.     djSP;
  1005.     GV *gv = cxstack[cxstack_ix].blk_sub.gv;
  1006.     register IO *io = GvIOp(gv);
  1007.     PerlIO *ofp = IoOFP(io);
  1008.     PerlIO *fp;
  1009.     SV **newsp;
  1010.     I32 gimme;
  1011.     register PERL_CONTEXT *cx;
  1012.  
  1013.     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
  1014.       (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
  1015.     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
  1016.     PL_formtarget != PL_toptarget)
  1017.     {
  1018.     GV *fgv;
  1019.     CV *cv;
  1020.     if (!IoTOP_GV(io)) {
  1021.         GV *topgv;
  1022.         SV *topname;
  1023.  
  1024.         if (!IoTOP_NAME(io)) {
  1025.         if (!IoFMT_NAME(io))
  1026.             IoFMT_NAME(io) = savepv(GvNAME(gv));
  1027.         topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
  1028.         topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
  1029.         if ((topgv && GvFORM(topgv)) ||
  1030.           !gv_fetchpv("top",FALSE,SVt_PVFM))
  1031.             IoTOP_NAME(io) = savepv(SvPVX(topname));
  1032.         else
  1033.             IoTOP_NAME(io) = savepv("top");
  1034.         }
  1035.         topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
  1036.         if (!topgv || !GvFORM(topgv)) {
  1037.         IoLINES_LEFT(io) = 100000000;
  1038.         goto forget_top;
  1039.         }
  1040.         IoTOP_GV(io) = topgv;
  1041.     }
  1042.     if (IoFLAGS(io) & IOf_DIDTOP) {    /* Oh dear.  It still doesn't fit. */
  1043.         I32 lines = IoLINES_LEFT(io);
  1044.         char *s = SvPVX(PL_formtarget);
  1045.         if (lines <= 0)        /* Yow, header didn't even fit!!! */
  1046.         goto forget_top;
  1047.         while (lines-- > 0) {
  1048.         s = strchr(s, '\n');
  1049.         if (!s)
  1050.             break;
  1051.         s++;
  1052.         }
  1053.         if (s) {
  1054.         PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
  1055.         sv_chop(PL_formtarget, s);
  1056.         FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
  1057.         }
  1058.     }
  1059.     if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
  1060.         PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
  1061.     IoLINES_LEFT(io) = IoPAGE_LEN(io);
  1062.     IoPAGE(io)++;
  1063.     PL_formtarget = PL_toptarget;
  1064.     IoFLAGS(io) |= IOf_DIDTOP;
  1065.     fgv = IoTOP_GV(io);
  1066.     if (!fgv)
  1067.         DIE("bad top format reference");
  1068.     cv = GvFORM(fgv);
  1069.     if (!cv) {
  1070.         SV *tmpsv = sv_newmortal();
  1071.         gv_efullname3(tmpsv, fgv, Nullch);
  1072.         DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
  1073.     }
  1074.     if (CvCLONE(cv))
  1075.         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
  1076.     return doform(cv,gv,PL_op);
  1077.     }
  1078.  
  1079.   forget_top:
  1080.     POPBLOCK(cx,PL_curpm);
  1081.     POPFORMAT(cx);
  1082.     LEAVE;
  1083.  
  1084.     fp = IoOFP(io);
  1085.     if (!fp) {
  1086.     if (PL_dowarn) {
  1087.         if (IoIFP(io))
  1088.         warn("Filehandle only opened for input");
  1089.         else
  1090.         warn("Write on closed filehandle");
  1091.     }
  1092.     PUSHs(&PL_sv_no);
  1093.     }
  1094.     else {
  1095.     if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
  1096.         if (PL_dowarn)
  1097.         warn("page overflow");
  1098.     }
  1099.     if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
  1100.         PerlIO_error(fp))
  1101.         PUSHs(&PL_sv_no);
  1102.     else {
  1103.         FmLINES(PL_formtarget) = 0;
  1104.         SvCUR_set(PL_formtarget, 0);
  1105.         *SvEND(PL_formtarget) = '\0';
  1106.         if (IoFLAGS(io) & IOf_FLUSH)
  1107.         (void)PerlIO_flush(fp);
  1108.         PUSHs(&PL_sv_yes);
  1109.     }
  1110.     }
  1111.     PL_formtarget = PL_bodytarget;
  1112.     PUTBACK;
  1113.     return pop_return();
  1114. }
  1115.  
  1116. PP(pp_prtf)
  1117. {
  1118.     djSP; dMARK; dORIGMARK;
  1119.     GV *gv;
  1120.     IO *io;
  1121.     PerlIO *fp;
  1122.     SV *sv;
  1123.     MAGIC *mg;
  1124.  
  1125.     if (PL_op->op_flags & OPf_STACKED)
  1126.     gv = (GV*)*++MARK;
  1127.     else
  1128.     gv = PL_defoutgv;
  1129.  
  1130.     if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
  1131.     if (MARK == ORIGMARK) {
  1132.         MEXTEND(SP, 1);
  1133.         ++MARK;
  1134.         Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
  1135.         ++SP;
  1136.     }
  1137.     PUSHMARK(MARK - 1);
  1138.     *MARK = mg->mg_obj;
  1139.     PUTBACK;
  1140.     ENTER;
  1141.     perl_call_method("PRINTF", G_SCALAR);
  1142.     LEAVE;
  1143.     SPAGAIN;
  1144.     MARK = ORIGMARK + 1;
  1145.     *MARK = *SP;
  1146.     SP = MARK;
  1147.     RETURN;
  1148.     }
  1149.  
  1150.     sv = NEWSV(0,0);
  1151.     if (!(io = GvIO(gv))) {
  1152.     if (PL_dowarn) {
  1153.         gv_fullname3(sv, gv, Nullch);
  1154.         warn("Filehandle %s never opened", SvPV(sv,PL_na));
  1155.     }
  1156.     SETERRNO(EBADF,RMS$_IFI);
  1157.     goto just_say_no;
  1158.     }
  1159.     else if (!(fp = IoOFP(io))) {
  1160.     if (PL_dowarn)  {
  1161.         gv_fullname3(sv, gv, Nullch);
  1162.         if (IoIFP(io))
  1163.         warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
  1164.         else
  1165.         warn("printf on closed filehandle %s", SvPV(sv,PL_na));
  1166.     }
  1167.     SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
  1168.     goto just_say_no;
  1169.     }
  1170.     else {
  1171. #ifdef USE_LOCALE_NUMERIC
  1172.     if (PL_op->op_private & OPpLOCALE)
  1173.         SET_NUMERIC_LOCAL();
  1174.     else
  1175.         SET_NUMERIC_STANDARD();
  1176. #endif
  1177.     do_sprintf(sv, SP - MARK, MARK + 1);
  1178.     if (!do_print(sv, fp))
  1179.         goto just_say_no;
  1180.  
  1181.     if (IoFLAGS(io) & IOf_FLUSH)
  1182.         if (PerlIO_flush(fp) == EOF)
  1183.         goto just_say_no;
  1184.     }
  1185.     SvREFCNT_dec(sv);
  1186.     SP = ORIGMARK;
  1187.     PUSHs(&PL_sv_yes);
  1188.     RETURN;
  1189.  
  1190.   just_say_no:
  1191.     SvREFCNT_dec(sv);
  1192.     SP = ORIGMARK;
  1193.     PUSHs(&PL_sv_undef);
  1194.     RETURN;
  1195. }
  1196.  
  1197. PP(pp_sysopen)
  1198. {
  1199.     djSP;
  1200.     GV *gv;
  1201.     SV *sv;
  1202.     char *tmps;
  1203.     STRLEN len;
  1204.     int mode, perm;
  1205.  
  1206.     if (MAXARG > 3)
  1207.     perm = POPi;
  1208.     else
  1209.     perm = 0666;
  1210.     mode = POPi;
  1211.     sv = POPs;
  1212.     gv = (GV *)POPs;
  1213.  
  1214.     tmps = SvPV(sv, len);
  1215.     if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
  1216.     IoLINES(GvIOp(gv)) = 0;
  1217.     PUSHs(&PL_sv_yes);
  1218.     }
  1219.     else {
  1220.     PUSHs(&PL_sv_undef);
  1221.     }
  1222.     RETURN;
  1223. }
  1224.  
  1225. PP(pp_sysread)
  1226. {
  1227.     djSP; dMARK; dORIGMARK; dTARGET;
  1228.     int offset;
  1229.     GV *gv;
  1230.     IO *io;
  1231.     char *buffer;
  1232.     SSize_t length;
  1233.     Sock_size_t bufsize;
  1234.     SV *bufsv;
  1235.     STRLEN blen;
  1236.     MAGIC *mg;
  1237.  
  1238.     gv = (GV*)*++MARK;
  1239.     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
  1240.     SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
  1241.     {
  1242.     SV *sv;
  1243.     
  1244.     PUSHMARK(MARK-1);
  1245.     *MARK = mg->mg_obj;
  1246.     ENTER;
  1247.     perl_call_method("READ", G_SCALAR);
  1248.     LEAVE;
  1249.     SPAGAIN;
  1250.     sv = POPs;
  1251.     SP = ORIGMARK;
  1252.     PUSHs(sv);
  1253.     RETURN;
  1254.     }
  1255.  
  1256.     if (!gv)
  1257.     goto say_undef;
  1258.     bufsv = *++MARK;
  1259.     if (! SvOK(bufsv))
  1260.     sv_setpvn(bufsv, "", 0);
  1261.     buffer = SvPV_force(bufsv, blen);
  1262.     length = SvIVx(*++MARK);
  1263.     if (length < 0)
  1264.     DIE("Negative length");
  1265.     SETERRNO(0,0);
  1266.     if (MARK < SP)
  1267.     offset = SvIVx(*++MARK);
  1268.     else
  1269.     offset = 0;
  1270.     io = GvIO(gv);
  1271.     if (!io || !IoIFP(io))
  1272.     goto say_undef;
  1273. #ifdef HAS_SOCKET
  1274.     if (PL_op->op_type == OP_RECV) {
  1275.     char namebuf[MAXPATHLEN];
  1276. #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
  1277.     bufsize = sizeof (struct sockaddr_in);
  1278. #else
  1279.     bufsize = sizeof namebuf;
  1280. #endif
  1281.     buffer = SvGROW(bufsv, length+1);
  1282.     /* 'offset' means 'flags' here */
  1283.     length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
  1284.               (struct sockaddr *)namebuf, &bufsize);
  1285.     if (length < 0)
  1286.         RETPUSHUNDEF;
  1287.     SvCUR_set(bufsv, length);
  1288.     *SvEND(bufsv) = '\0';
  1289.     (void)SvPOK_only(bufsv);
  1290.     SvSETMAGIC(bufsv);
  1291.     /* This should not be marked tainted if the fp is marked clean */
  1292.     if (!(IoFLAGS(io) & IOf_UNTAINT))
  1293.         SvTAINTED_on(bufsv);
  1294.     SP = ORIGMARK;
  1295.     sv_setpvn(TARG, namebuf, bufsize);
  1296.     PUSHs(TARG);
  1297.     RETURN;
  1298.     }
  1299. #else
  1300.     if (PL_op->op_type == OP_RECV)
  1301.     DIE(no_sock_func, "recv");
  1302. #endif
  1303.     if (offset < 0) {
  1304.     if (-offset > blen)
  1305.         DIE("Offset outside string");
  1306.     offset += blen;
  1307.     }
  1308.     bufsize = SvCUR(bufsv);
  1309.     buffer = SvGROW(bufsv, length+offset+1);
  1310.     if (offset > bufsize) { /* Zero any newly allocated space */
  1311.         Zero(buffer+bufsize, offset-bufsize, char);
  1312.     }
  1313.     if (PL_op->op_type == OP_SYSREAD) {
  1314.     length = PerlLIO_read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
  1315.     }
  1316.     else
  1317. #ifdef HAS_SOCKET__bad_code_maybe
  1318.     if (IoTYPE(io) == 's') {
  1319.     char namebuf[MAXPATHLEN];
  1320. #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
  1321.     bufsize = sizeof (struct sockaddr_in);
  1322. #else
  1323.     bufsize = sizeof namebuf;
  1324. #endif
  1325.     length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
  1326.               (struct sockaddr *)namebuf, &bufsize);
  1327.     }
  1328.     else
  1329. #endif
  1330.     {
  1331.     length = PerlIO_read(IoIFP(io), buffer+offset, length);
  1332.     /* fread() returns 0 on both error and EOF */
  1333.     if (length == 0 && PerlIO_error(IoIFP(io)))
  1334.         length = -1;
  1335.     }
  1336.     if (length < 0)
  1337.     goto say_undef;
  1338.     SvCUR_set(bufsv, length+offset);
  1339.     *SvEND(bufsv) = '\0';
  1340.     (void)SvPOK_only(bufsv);
  1341.     SvSETMAGIC(bufsv);
  1342.     /* This should not be marked tainted if the fp is marked clean */
  1343.     if (!(IoFLAGS(io) & IOf_UNTAINT))
  1344.     SvTAINTED_on(bufsv);
  1345.     SP = ORIGMARK;
  1346.     PUSHi(length);
  1347.     RETURN;
  1348.  
  1349.   say_undef:
  1350.     SP = ORIGMARK;
  1351.     RETPUSHUNDEF;
  1352. }
  1353.  
  1354. PP(pp_syswrite)
  1355. {
  1356.     return pp_send(ARGS);
  1357. }
  1358.  
  1359. PP(pp_send)
  1360. {
  1361.     djSP; dMARK; dORIGMARK; dTARGET;
  1362.     GV *gv;
  1363.     IO *io;
  1364.     int offset;
  1365.     SV *bufsv;
  1366.     char *buffer;
  1367.     int length;
  1368.     STRLEN blen;
  1369.     MAGIC *mg;
  1370.  
  1371.     gv = (GV*)*++MARK;
  1372.     if (PL_op->op_type == OP_SYSWRITE &&
  1373.     SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
  1374.     {
  1375.     SV *sv;
  1376.     
  1377.     PUSHMARK(MARK-1);
  1378.     *MARK = mg->mg_obj;
  1379.     ENTER;
  1380.     perl_call_method("WRITE", G_SCALAR);
  1381.     LEAVE;
  1382.     SPAGAIN;
  1383.     sv = POPs;
  1384.     SP = ORIGMARK;
  1385.     PUSHs(sv);
  1386.     RETURN;
  1387.     }
  1388.     if (!gv)
  1389.     goto say_undef;
  1390.     bufsv = *++MARK;
  1391.     buffer = SvPV(bufsv, blen);
  1392.     length = SvIVx(*++MARK);
  1393.     if (length < 0)
  1394.     DIE("Negative length");
  1395.     SETERRNO(0,0);
  1396.     io = GvIO(gv);
  1397.     if (!io || !IoIFP(io)) {
  1398.     length = -1;
  1399.     if (PL_dowarn) {
  1400.         if (PL_op->op_type == OP_SYSWRITE)
  1401.         warn("Syswrite on closed filehandle");
  1402.         else
  1403.         warn("Send on closed socket");
  1404.     }
  1405.     }
  1406.     else if (PL_op->op_type == OP_SYSWRITE) {
  1407.     if (MARK < SP) {
  1408.         offset = SvIVx(*++MARK);
  1409.         if (offset < 0) {
  1410.         if (-offset > blen)
  1411.             DIE("Offset outside string");
  1412.         offset += blen;
  1413.         } else if (offset >= blen && blen > 0)
  1414.         DIE("Offset outside string");
  1415.     } else
  1416.         offset = 0;
  1417.     if (length > blen - offset)
  1418.         length = blen - offset;
  1419.     length = PerlLIO_write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
  1420.     }
  1421. #ifdef HAS_SOCKET
  1422.     else if (SP > MARK) {
  1423.     char *sockbuf;
  1424.     STRLEN mlen;
  1425.     sockbuf = SvPVx(*++MARK, mlen);
  1426.     length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
  1427.                 (struct sockaddr *)sockbuf, mlen);
  1428.     }
  1429.     else
  1430.     length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
  1431.  
  1432. #else
  1433.     else
  1434.     DIE(no_sock_func, "send");
  1435. #endif
  1436.     if (length < 0)
  1437.     goto say_undef;
  1438.     SP = ORIGMARK;
  1439.     PUSHi(length);
  1440.     RETURN;
  1441.  
  1442.   say_undef:
  1443.     SP = ORIGMARK;
  1444.     RETPUSHUNDEF;
  1445. }
  1446.  
  1447. PP(pp_recv)
  1448. {
  1449.     return pp_sysread(ARGS);
  1450. }
  1451.  
  1452. PP(pp_eof)
  1453. {
  1454.     djSP;
  1455.     GV *gv;
  1456.  
  1457.     if (MAXARG <= 0)
  1458.     gv = PL_last_in_gv;
  1459.     else
  1460.     gv = PL_last_in_gv = (GV*)POPs;
  1461.     PUSHs(boolSV(!gv || do_eof(gv)));
  1462.     RETURN;
  1463. }
  1464.  
  1465. PP(pp_tell)
  1466. {
  1467.     djSP; dTARGET;
  1468.     GV *gv;
  1469.  
  1470.     if (MAXARG <= 0)
  1471.     gv = PL_last_in_gv;
  1472.     else
  1473.     gv = PL_last_in_gv = (GV*)POPs;
  1474.     PUSHi( do_tell(gv) );
  1475.     RETURN;
  1476. }
  1477.  
  1478. PP(pp_seek)
  1479. {
  1480.     return pp_sysseek(ARGS);
  1481. }
  1482.  
  1483. PP(pp_sysseek)
  1484. {
  1485.     djSP;
  1486.     GV *gv;
  1487.     int whence = POPi;
  1488.     long offset = POPl;
  1489.  
  1490.     gv = PL_last_in_gv = (GV*)POPs;
  1491.     if (PL_op->op_type == OP_SEEK)
  1492.     PUSHs(boolSV(do_seek(gv, offset, whence)));
  1493.     else {
  1494.     long n = do_sysseek(gv, offset, whence);
  1495.     PUSHs((n < 0) ? &PL_sv_undef
  1496.           : sv_2mortal(n ? newSViv((IV)n)
  1497.                : newSVpv(zero_but_true, ZBTLEN)));
  1498.     }
  1499.     RETURN;
  1500. }
  1501.  
  1502. PP(pp_truncate)
  1503. {
  1504.     djSP;
  1505.     Off_t len = (Off_t)POPn;
  1506.     int result = 1;
  1507.     GV *tmpgv;
  1508.  
  1509.     SETERRNO(0,0);
  1510. #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
  1511.     if (PL_op->op_flags & OPf_SPECIAL) {
  1512.     tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
  1513.     do_ftruncate:
  1514.     TAINT_PROPER("truncate");
  1515.     if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
  1516. #ifdef HAS_TRUNCATE
  1517.       ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
  1518. #else 
  1519.       my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
  1520. #endif
  1521.         result = 0;
  1522.     }
  1523.     else {
  1524.     SV *sv = POPs;
  1525.     char *name;
  1526.  
  1527.     if (SvTYPE(sv) == SVt_PVGV) {
  1528.         tmpgv = (GV*)sv;        /* *main::FRED for example */
  1529.         goto do_ftruncate;
  1530.     }
  1531.     else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
  1532.         tmpgv = (GV*) SvRV(sv);    /* \*main::FRED for example */
  1533.         goto do_ftruncate;
  1534.     }
  1535.  
  1536.     name = SvPV(sv, PL_na);
  1537.     TAINT_PROPER("truncate");
  1538. #ifdef HAS_TRUNCATE
  1539.     if (truncate(name, len) < 0)
  1540.         result = 0;
  1541. #else
  1542.     {
  1543.         int tmpfd;
  1544.         if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
  1545.         result = 0;
  1546.         else {
  1547.         if (my_chsize(tmpfd, len) < 0)
  1548.             result = 0;
  1549.         PerlLIO_close(tmpfd);
  1550.         }
  1551.     }
  1552. #endif
  1553.     }
  1554.  
  1555.     if (result)
  1556.     RETPUSHYES;
  1557.     if (!errno)
  1558.     SETERRNO(EBADF,RMS$_IFI);
  1559.     RETPUSHUNDEF;
  1560. #else
  1561.     DIE("truncate not implemented");
  1562. #endif
  1563. }
  1564.  
  1565. PP(pp_fcntl)
  1566. {
  1567.     return pp_ioctl(ARGS);
  1568. }
  1569.  
  1570. PP(pp_ioctl)
  1571. {
  1572.     djSP; dTARGET;
  1573.     SV *argsv = POPs;
  1574.     unsigned int func = U_I(POPn);
  1575.     int optype = PL_op->op_type;
  1576.     char *s;
  1577.     IV retval;
  1578.     GV *gv = (GV*)POPs;
  1579.     IO *io = GvIOn(gv);
  1580.  
  1581.     if (!io || !argsv || !IoIFP(io)) {
  1582.     SETERRNO(EBADF,RMS$_IFI);    /* well, sort of... */
  1583.     RETPUSHUNDEF;
  1584.     }
  1585.  
  1586.     if (SvPOK(argsv) || !SvNIOK(argsv)) {
  1587.     STRLEN len;
  1588.     STRLEN need;
  1589.     s = SvPV_force(argsv, len);
  1590.     need = IOCPARM_LEN(func);
  1591.     if (len < need) {
  1592.         s = Sv_Grow(argsv, need + 1);
  1593.         SvCUR_set(argsv, need);
  1594.     }
  1595.  
  1596.     s[SvCUR(argsv)] = 17;    /* a little sanity check here */
  1597.     }
  1598.     else {
  1599.     retval = SvIV(argsv);
  1600.     s = (char*)retval;        /* ouch */
  1601.     }
  1602.  
  1603.     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
  1604.  
  1605.     if (optype == OP_IOCTL)
  1606. #ifdef HAS_IOCTL
  1607.     retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
  1608. #else
  1609.     DIE("ioctl is not implemented");
  1610. #endif
  1611.     else
  1612. #ifdef HAS_FCNTL
  1613. #if defined(OS2) && defined(__EMX__)
  1614.     retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
  1615. #else
  1616.     retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
  1617. #endif 
  1618. #else
  1619.     DIE("fcntl is not implemented");
  1620. #endif
  1621.  
  1622.     if (SvPOK(argsv)) {
  1623.     if (s[SvCUR(argsv)] != 17)
  1624.         DIE("Possible memory corruption: %s overflowed 3rd argument",
  1625.         op_name[optype]);
  1626.     s[SvCUR(argsv)] = 0;        /* put our null back */
  1627.     SvSETMAGIC(argsv);        /* Assume it has changed */
  1628.     }
  1629.  
  1630.     if (retval == -1)
  1631.     RETPUSHUNDEF;
  1632.     if (retval != 0) {
  1633.     PUSHi(retval);
  1634.     }
  1635.     else {
  1636.     PUSHp(zero_but_true, ZBTLEN);
  1637.     }
  1638.     RETURN;
  1639. }
  1640.  
  1641. PP(pp_flock)
  1642. {
  1643.     djSP; dTARGET;
  1644.     I32 value;
  1645.     int argtype;
  1646.     GV *gv;
  1647.     PerlIO *fp;
  1648.  
  1649. #ifdef FLOCK
  1650.     argtype = POPi;
  1651.     if (MAXARG <= 0)
  1652.     gv = PL_last_in_gv;
  1653.     else
  1654.     gv = (GV*)POPs;
  1655.     if (gv && GvIO(gv))
  1656.     fp = IoIFP(GvIOp(gv));
  1657.     else
  1658.     fp = Nullfp;
  1659.     if (fp) {
  1660.     (void)PerlIO_flush(fp);
  1661.     value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
  1662.     }
  1663.     else
  1664.     value = 0;
  1665.     PUSHi(value);
  1666.     RETURN;
  1667. #else
  1668.     DIE(no_func, "flock()");
  1669. #endif
  1670. }
  1671.  
  1672. /* Sockets. */
  1673.  
  1674. PP(pp_socket)
  1675. {
  1676.     djSP;
  1677. #ifdef HAS_SOCKET
  1678.     GV *gv;
  1679.     register IO *io;
  1680.     int protocol = POPi;
  1681.     int type = POPi;
  1682.     int domain = POPi;
  1683.     int fd;
  1684.  
  1685.     gv = (GV*)POPs;
  1686.  
  1687.     if (!gv) {
  1688.     SETERRNO(EBADF,LIB$_INVARG);
  1689.     RETPUSHUNDEF;
  1690.     }
  1691.  
  1692.     io = GvIOn(gv);
  1693.     if (IoIFP(io))
  1694.     do_close(gv, FALSE);
  1695.  
  1696.     TAINT_PROPER("socket");
  1697.     fd = PerlSock_socket(domain, type, protocol);
  1698.     if (fd < 0)
  1699.     RETPUSHUNDEF;
  1700.     IoIFP(io) = PerlIO_fdopen(fd, "r");    /* stdio gets confused about sockets */
  1701.     IoOFP(io) = PerlIO_fdopen(fd, "w");
  1702.     IoTYPE(io) = 's';
  1703.     if (!IoIFP(io) || !IoOFP(io)) {
  1704.     if (IoIFP(io)) PerlIO_close(IoIFP(io));
  1705.     if (IoOFP(io)) PerlIO_close(IoOFP(io));
  1706.     if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
  1707.     RETPUSHUNDEF;
  1708.     }
  1709.  
  1710.     RETPUSHYES;
  1711. #else
  1712.     DIE(no_sock_func, "socket");
  1713. #endif
  1714. }
  1715.  
  1716. PP(pp_sockpair)
  1717. {
  1718.     djSP;
  1719. #ifdef HAS_SOCKETPAIR
  1720.     GV *gv1;
  1721.     GV *gv2;
  1722.     register IO *io1;
  1723.     register IO *io2;
  1724.     int protocol = POPi;
  1725.     int type = POPi;
  1726.     int domain = POPi;
  1727.     int fd[2];
  1728.  
  1729.     gv2 = (GV*)POPs;
  1730.     gv1 = (GV*)POPs;
  1731.     if (!gv1 || !gv2)
  1732.     RETPUSHUNDEF;
  1733.  
  1734.     io1 = GvIOn(gv1);
  1735.     io2 = GvIOn(gv2);
  1736.     if (IoIFP(io1))
  1737.     do_close(gv1, FALSE);
  1738.     if (IoIFP(io2))
  1739.     do_close(gv2, FALSE);
  1740.  
  1741.     TAINT_PROPER("socketpair");
  1742.     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
  1743.     RETPUSHUNDEF;
  1744.     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
  1745.     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
  1746.     IoTYPE(io1) = 's';
  1747.     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
  1748.     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
  1749.     IoTYPE(io2) = 's';
  1750.     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
  1751.     if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
  1752.     if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
  1753.     if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
  1754.     if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
  1755.     if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
  1756.     if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
  1757.     RETPUSHUNDEF;
  1758.     }
  1759.  
  1760.     RETPUSHYES;
  1761. #else
  1762.     DIE(no_sock_func, "socketpair");
  1763. #endif
  1764. }
  1765.  
  1766. PP(pp_bind)
  1767. {
  1768.     djSP;
  1769. #ifdef HAS_SOCKET
  1770. #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
  1771.     extern GETPRIVMODE();
  1772.     extern GETUSERMODE();
  1773. #endif
  1774.     SV *addrsv = POPs;
  1775.     char *addr;
  1776.     GV *gv = (GV*)POPs;
  1777.     register IO *io = GvIOn(gv);
  1778.     STRLEN len;
  1779.     int bind_ok = 0;
  1780. #ifdef MPE
  1781.     int mpeprivmode = 0;
  1782. #endif
  1783.  
  1784.     if (!io || !IoIFP(io))
  1785.     goto nuts;
  1786.  
  1787.     addr = SvPV(addrsv, len);
  1788.     TAINT_PROPER("bind");
  1789. #ifdef MPE /* Deal with MPE bind() peculiarities */
  1790.     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
  1791.         /* The address *MUST* stupidly be zero. */
  1792.         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
  1793.         /* PRIV mode is required to bind() to ports < 1024. */
  1794.         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
  1795.             ((struct sockaddr_in *)addr)->sin_port > 0) {
  1796.             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
  1797.         mpeprivmode = 1;
  1798.     }
  1799.     }
  1800. #endif /* MPE */
  1801.     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
  1802.               (struct sockaddr *)addr, len) >= 0)
  1803.     bind_ok = 1;
  1804.  
  1805. #ifdef MPE /* Switch back to USER mode */
  1806.     if (mpeprivmode)
  1807.     GETUSERMODE();
  1808. #endif /* MPE */
  1809.  
  1810.     if (bind_ok)
  1811.     RETPUSHYES;
  1812.     else
  1813.     RETPUSHUNDEF;
  1814.  
  1815. nuts:
  1816.     if (PL_dowarn)
  1817.     warn("bind() on closed fd");
  1818.     SETERRNO(EBADF,SS$_IVCHAN);
  1819.     RETPUSHUNDEF;
  1820. #else
  1821.     DIE(no_sock_func, "bind");
  1822. #endif
  1823. }
  1824.  
  1825. PP(pp_connect)
  1826. {
  1827.     djSP;
  1828. #ifdef HAS_SOCKET
  1829.     SV *addrsv = POPs;
  1830.     char *addr;
  1831.     GV *gv = (GV*)POPs;
  1832.     register IO *io = GvIOn(gv);
  1833.     STRLEN len;
  1834.  
  1835.     if (!io || !IoIFP(io))
  1836.     goto nuts;
  1837.  
  1838.     addr = SvPV(addrsv, len);
  1839.     TAINT_PROPER("connect");
  1840.     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
  1841.     RETPUSHYES;
  1842.     else
  1843.     RETPUSHUNDEF;
  1844.  
  1845. nuts:
  1846.     if (PL_dowarn)
  1847.     warn("connect() on closed fd");
  1848.     SETERRNO(EBADF,SS$_IVCHAN);
  1849.     RETPUSHUNDEF;
  1850. #else
  1851.     DIE(no_sock_func, "connect");
  1852. #endif
  1853. }
  1854.  
  1855. PP(pp_listen)
  1856. {
  1857.     djSP;
  1858. #ifdef HAS_SOCKET
  1859.     int backlog = POPi;
  1860.     GV *gv = (GV*)POPs;
  1861.     register IO *io = GvIOn(gv);
  1862.  
  1863.     if (!io || !IoIFP(io))
  1864.     goto nuts;
  1865.  
  1866.     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
  1867.     RETPUSHYES;
  1868.     else
  1869.     RETPUSHUNDEF;
  1870.  
  1871. nuts:
  1872.     if (PL_dowarn)
  1873.     warn("listen() on closed fd");
  1874.     SETERRNO(EBADF,SS$_IVCHAN);
  1875.     RETPUSHUNDEF;
  1876. #else
  1877.     DIE(no_sock_func, "listen");
  1878. #endif
  1879. }
  1880.  
  1881. PP(pp_accept)
  1882. {
  1883.     djSP; dTARGET;
  1884. #ifdef HAS_SOCKET
  1885.     GV *ngv;
  1886.     GV *ggv;
  1887.     register IO *nstio;
  1888.     register IO *gstio;
  1889.     struct sockaddr saddr;    /* use a struct to avoid alignment problems */
  1890.     Sock_size_t len = sizeof saddr;
  1891.     int fd;
  1892.  
  1893.     ggv = (GV*)POPs;
  1894.     ngv = (GV*)POPs;
  1895.  
  1896.     if (!ngv)
  1897.     goto badexit;
  1898.     if (!ggv)
  1899.     goto nuts;
  1900.  
  1901.     gstio = GvIO(ggv);
  1902.     if (!gstio || !IoIFP(gstio))
  1903.     goto nuts;
  1904.  
  1905.     nstio = GvIOn(ngv);
  1906.     if (IoIFP(nstio))
  1907.     do_close(ngv, FALSE);
  1908.  
  1909.     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
  1910.     if (fd < 0)
  1911.     goto badexit;
  1912.     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
  1913.     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
  1914.     IoTYPE(nstio) = 's';
  1915.     if (!IoIFP(nstio) || !IoOFP(nstio)) {
  1916.     if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
  1917.     if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
  1918.     if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
  1919.     goto badexit;
  1920.     }
  1921.  
  1922.     PUSHp((char *)&saddr, len);
  1923.     RETURN;
  1924.  
  1925. nuts:
  1926.     if (PL_dowarn)
  1927.     warn("accept() on closed fd");
  1928.     SETERRNO(EBADF,SS$_IVCHAN);
  1929.  
  1930. badexit:
  1931.     RETPUSHUNDEF;
  1932.  
  1933. #else
  1934.     DIE(no_sock_func, "accept");
  1935. #endif
  1936. }
  1937.  
  1938. PP(pp_shutdown)
  1939. {
  1940.     djSP; dTARGET;
  1941. #ifdef HAS_SOCKET
  1942.     int how = POPi;
  1943.     GV *gv = (GV*)POPs;
  1944.     register IO *io = GvIOn(gv);
  1945.  
  1946.     if (!io || !IoIFP(io))
  1947.     goto nuts;
  1948.  
  1949.     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
  1950.     RETURN;
  1951.  
  1952. nuts:
  1953.     if (PL_dowarn)
  1954.     warn("shutdown() on closed fd");
  1955.     SETERRNO(EBADF,SS$_IVCHAN);
  1956.     RETPUSHUNDEF;
  1957. #else
  1958.     DIE(no_sock_func, "shutdown");
  1959. #endif
  1960. }
  1961.  
  1962. PP(pp_gsockopt)
  1963. {
  1964. #ifdef HAS_SOCKET
  1965.     return pp_ssockopt(ARGS);
  1966. #else
  1967.     DIE(no_sock_func, "getsockopt");
  1968. #endif
  1969. }
  1970.  
  1971. PP(pp_ssockopt)
  1972. {
  1973.     djSP;
  1974. #ifdef HAS_SOCKET
  1975.     int optype = PL_op->op_type;
  1976.     SV *sv;
  1977.     int fd;
  1978.     unsigned int optname;
  1979.     unsigned int lvl;
  1980.     GV *gv;
  1981.     register IO *io;
  1982.     Sock_size_t len;
  1983.  
  1984.     if (optype == OP_GSOCKOPT)
  1985.     sv = sv_2mortal(NEWSV(22, 257));
  1986.     else
  1987.     sv = POPs;
  1988.     optname = (unsigned int) POPi;
  1989.     lvl = (unsigned int) POPi;
  1990.  
  1991.     gv = (GV*)POPs;
  1992.     io = GvIOn(gv);
  1993.     if (!io || !IoIFP(io))
  1994.     goto nuts;
  1995.  
  1996.     fd = PerlIO_fileno(IoIFP(io));
  1997.     switch (optype) {
  1998.     case OP_GSOCKOPT:
  1999.     SvGROW(sv, 257);
  2000.     (void)SvPOK_only(sv);
  2001.     SvCUR_set(sv,256);
  2002.     *SvEND(sv) ='\0';
  2003.     len = SvCUR(sv);
  2004.     if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
  2005.         goto nuts2;
  2006.     SvCUR_set(sv, len);
  2007.     *SvEND(sv) ='\0';
  2008.     PUSHs(sv);
  2009.     break;
  2010.     case OP_SSOCKOPT: {
  2011.         char *buf;
  2012.         int aint;
  2013.         if (SvPOKp(sv)) {
  2014.         buf = SvPV(sv, PL_na);
  2015.         len = PL_na;
  2016.         }
  2017.         else {
  2018.         aint = (int)SvIV(sv);
  2019.         buf = (char*)&aint;
  2020.         len = sizeof(int);
  2021.         }
  2022.         if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
  2023.         goto nuts2;
  2024.         PUSHs(&PL_sv_yes);
  2025.     }
  2026.     break;
  2027.     }
  2028.     RETURN;
  2029.  
  2030. nuts:
  2031.     if (PL_dowarn)
  2032.     warn("[gs]etsockopt() on closed fd");
  2033.     SETERRNO(EBADF,SS$_IVCHAN);
  2034. nuts2:
  2035.     RETPUSHUNDEF;
  2036.  
  2037. #else
  2038.     DIE(no_sock_func, "setsockopt");
  2039. #endif
  2040. }
  2041.  
  2042. PP(pp_getsockname)
  2043. {
  2044. #ifdef HAS_SOCKET
  2045.     return pp_getpeername(ARGS);
  2046. #else
  2047.     DIE(no_sock_func, "getsockname");
  2048. #endif
  2049. }
  2050.  
  2051. PP(pp_getpeername)
  2052. {
  2053.     djSP;
  2054. #ifdef HAS_SOCKET
  2055.     int optype = PL_op->op_type;
  2056.     SV *sv;
  2057.     int fd;
  2058.     GV *gv = (GV*)POPs;
  2059.     register IO *io = GvIOn(gv);
  2060.     Sock_size_t len;
  2061.  
  2062.     if (!io || !IoIFP(io))
  2063.     goto nuts;
  2064.  
  2065.     sv = sv_2mortal(NEWSV(22, 257));
  2066.     (void)SvPOK_only(sv);
  2067.     len = 256;
  2068.     SvCUR_set(sv, len);
  2069.     *SvEND(sv) ='\0';
  2070.     fd = PerlIO_fileno(IoIFP(io));
  2071.     switch (optype) {
  2072.     case OP_GETSOCKNAME:
  2073.     if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
  2074.         goto nuts2;
  2075.     break;
  2076.     case OP_GETPEERNAME:
  2077.     if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
  2078.         goto nuts2;
  2079. #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
  2080.     {
  2081.         static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
  2082.         /* If the call succeeded, make sure we don't have a zeroed port/addr */
  2083.         if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
  2084.         !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
  2085.             sizeof(u_short) + sizeof(struct in_addr))) {
  2086.         goto nuts2;        
  2087.         }
  2088.     }
  2089. #endif
  2090.     break;
  2091.     }
  2092. #ifdef BOGUS_GETNAME_RETURN
  2093.     /* Interactive Unix, getpeername() and getsockname()
  2094.       does not return valid namelen */
  2095.     if (len == BOGUS_GETNAME_RETURN)
  2096.     len = sizeof(struct sockaddr);
  2097. #endif
  2098.     SvCUR_set(sv, len);
  2099.     *SvEND(sv) ='\0';
  2100.     PUSHs(sv);
  2101.     RETURN;
  2102.  
  2103. nuts:
  2104.     if (PL_dowarn)
  2105.     warn("get{sock, peer}name() on closed fd");
  2106.     SETERRNO(EBADF,SS$_IVCHAN);
  2107. nuts2:
  2108.     RETPUSHUNDEF;
  2109.  
  2110. #else
  2111.     DIE(no_sock_func, "getpeername");
  2112. #endif
  2113. }
  2114.  
  2115. /* Stat calls. */
  2116.  
  2117. PP(pp_lstat)
  2118. {
  2119.     return pp_stat(ARGS);
  2120. }
  2121.  
  2122. PP(pp_stat)
  2123. {
  2124.     djSP;
  2125.     GV *tmpgv;
  2126.     I32 gimme;
  2127.     I32 max = 13;
  2128.  
  2129.     if (PL_op->op_flags & OPf_REF) {
  2130.     tmpgv = cGVOP->op_gv;
  2131.       do_fstat:
  2132.     if (tmpgv != PL_defgv) {
  2133.         PL_laststype = OP_STAT;
  2134.         PL_statgv = tmpgv;
  2135.         sv_setpv(PL_statname, "");
  2136.         PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
  2137.         ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
  2138.     }
  2139.     if (PL_laststatval < 0)
  2140.         max = 0;
  2141.     }
  2142.     else {
  2143.     SV* sv = POPs;
  2144.     if (SvTYPE(sv) == SVt_PVGV) {
  2145.         tmpgv = (GV*)sv;
  2146.         goto do_fstat;
  2147.     }
  2148.     else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
  2149.         tmpgv = (GV*)SvRV(sv);
  2150.         goto do_fstat;
  2151.     }
  2152.     sv_setpv(PL_statname, SvPV(sv,PL_na));
  2153.     PL_statgv = Nullgv;
  2154. #ifdef HAS_LSTAT
  2155.     PL_laststype = PL_op->op_type;
  2156.     if (PL_op->op_type == OP_LSTAT)
  2157.         PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, PL_na), &PL_statcache);
  2158.     else
  2159. #endif
  2160.         PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache);
  2161.     if (PL_laststatval < 0) {
  2162.         if (PL_dowarn && strchr(SvPV(PL_statname, PL_na), '\n'))
  2163.         warn(warn_nl, "stat");
  2164.         max = 0;
  2165.     }
  2166.     }
  2167.  
  2168.     gimme = GIMME_V;
  2169.     if (gimme != G_ARRAY) {
  2170.     if (gimme != G_VOID)
  2171.         XPUSHs(boolSV(max));
  2172.     RETURN;
  2173.     }
  2174.     if (max) {
  2175.     EXTEND(SP, max);
  2176.     EXTEND_MORTAL(max);
  2177.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
  2178.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
  2179.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
  2180.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
  2181.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
  2182.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
  2183. #ifdef USE_STAT_RDEV
  2184.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
  2185. #else
  2186.     PUSHs(sv_2mortal(newSVpv("", 0)));
  2187. #endif
  2188.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
  2189. #ifdef BIG_TIME
  2190.     PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
  2191.     PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
  2192.     PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
  2193. #else
  2194.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
  2195.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
  2196.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
  2197. #endif
  2198. #ifdef USE_STAT_BLOCKS
  2199.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
  2200.     PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
  2201. #else
  2202.     PUSHs(sv_2mortal(newSVpv("", 0)));
  2203.     PUSHs(sv_2mortal(newSVpv("", 0)));
  2204. #endif
  2205.     }
  2206.     RETURN;
  2207. }
  2208.  
  2209. PP(pp_ftrread)
  2210. {
  2211.     I32 result = my_stat(ARGS);
  2212.     djSP;
  2213.     if (result < 0)
  2214.     RETPUSHUNDEF;
  2215.     if (cando(S_IRUSR, 0, &PL_statcache))
  2216.     RETPUSHYES;
  2217.     RETPUSHNO;
  2218. }
  2219.  
  2220. PP(pp_ftrwrite)
  2221. {
  2222.     I32 result = my_stat(ARGS);
  2223.     djSP;
  2224.     if (result < 0)
  2225.     RETPUSHUNDEF;
  2226.     if (cando(S_IWUSR, 0, &PL_statcache))
  2227.     RETPUSHYES;
  2228.     RETPUSHNO;
  2229. }
  2230.  
  2231. PP(pp_ftrexec)
  2232. {
  2233.     I32 result = my_stat(ARGS);
  2234.     djSP;
  2235.     if (result < 0)
  2236.     RETPUSHUNDEF;
  2237.     if (cando(S_IXUSR, 0, &PL_statcache))
  2238.     RETPUSHYES;
  2239.     RETPUSHNO;
  2240. }
  2241.  
  2242. PP(pp_fteread)
  2243. {
  2244.     I32 result = my_stat(ARGS);
  2245.     djSP;
  2246.     if (result < 0)
  2247.     RETPUSHUNDEF;
  2248.     if (cando(S_IRUSR, 1, &PL_statcache))
  2249.     RETPUSHYES;
  2250.     RETPUSHNO;
  2251. }
  2252.  
  2253. PP(pp_ftewrite)
  2254. {
  2255.     I32 result = my_stat(ARGS);
  2256.     djSP;
  2257.     if (result < 0)
  2258.     RETPUSHUNDEF;
  2259.     if (cando(S_IWUSR, 1, &PL_statcache))
  2260.     RETPUSHYES;
  2261.     RETPUSHNO;
  2262. }
  2263.  
  2264. PP(pp_fteexec)
  2265. {
  2266.     I32 result = my_stat(ARGS);
  2267.     djSP;
  2268.     if (result < 0)
  2269.     RETPUSHUNDEF;
  2270.     if (cando(S_IXUSR, 1, &PL_statcache))
  2271.     RETPUSHYES;
  2272.     RETPUSHNO;
  2273. }
  2274.  
  2275. PP(pp_ftis)
  2276. {
  2277.     I32 result = my_stat(ARGS);
  2278.     djSP;
  2279.     if (result < 0)
  2280.     RETPUSHUNDEF;
  2281.     RETPUSHYES;
  2282. }
  2283.  
  2284. PP(pp_fteowned)
  2285. {
  2286.     return pp_ftrowned(ARGS);
  2287. }
  2288.  
  2289. PP(pp_ftrowned)
  2290. {
  2291.     I32 result = my_stat(ARGS);
  2292.     djSP;
  2293.     if (result < 0)
  2294.     RETPUSHUNDEF;
  2295.     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
  2296.     RETPUSHYES;
  2297.     RETPUSHNO;
  2298. }
  2299.  
  2300. PP(pp_ftzero)
  2301. {
  2302.     I32 result = my_stat(ARGS);
  2303.     djSP;
  2304.     if (result < 0)
  2305.     RETPUSHUNDEF;
  2306.     if (!PL_statcache.st_size)
  2307.     RETPUSHYES;
  2308.     RETPUSHNO;
  2309. }
  2310.  
  2311. PP(pp_ftsize)
  2312. {
  2313.     I32 result = my_stat(ARGS);
  2314.     djSP; dTARGET;
  2315.     if (result < 0)
  2316.     RETPUSHUNDEF;
  2317.     PUSHi(PL_statcache.st_size);
  2318.     RETURN;
  2319. }
  2320.  
  2321. PP(pp_ftmtime)
  2322. {
  2323.     I32 result = my_stat(ARGS);
  2324.     djSP; dTARGET;
  2325.     if (result < 0)
  2326.     RETPUSHUNDEF;
  2327.     PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
  2328.     RETURN;
  2329. }
  2330.  
  2331. PP(pp_ftatime)
  2332. {
  2333.     I32 result = my_stat(ARGS);
  2334.     djSP; dTARGET;
  2335.     if (result < 0)
  2336.     RETPUSHUNDEF;
  2337.     PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
  2338.     RETURN;
  2339. }
  2340.  
  2341. PP(pp_ftctime)
  2342. {
  2343.     I32 result = my_stat(ARGS);
  2344.     djSP; dTARGET;
  2345.     if (result < 0)
  2346.     RETPUSHUNDEF;
  2347.     PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
  2348.     RETURN;
  2349. }
  2350.  
  2351. PP(pp_ftsock)
  2352. {
  2353.     I32 result = my_stat(ARGS);
  2354.     djSP;
  2355.     if (result < 0)
  2356.     RETPUSHUNDEF;
  2357.     if (S_ISSOCK(PL_statcache.st_mode))
  2358.     RETPUSHYES;
  2359.     RETPUSHNO;
  2360. }
  2361.  
  2362. PP(pp_ftchr)
  2363. {
  2364.     I32 result = my_stat(ARGS);
  2365.     djSP;
  2366.     if (result < 0)
  2367.     RETPUSHUNDEF;
  2368.     if (S_ISCHR(PL_statcache.st_mode))
  2369.     RETPUSHYES;
  2370.     RETPUSHNO;
  2371. }
  2372.  
  2373. PP(pp_ftblk)
  2374. {
  2375.     I32 result = my_stat(ARGS);
  2376.     djSP;
  2377.     if (result < 0)
  2378.     RETPUSHUNDEF;
  2379.     if (S_ISBLK(PL_statcache.st_mode))
  2380.     RETPUSHYES;
  2381.     RETPUSHNO;
  2382. }
  2383.  
  2384. PP(pp_ftfile)
  2385. {
  2386.     I32 result = my_stat(ARGS);
  2387.     djSP;
  2388.     if (result < 0)
  2389.     RETPUSHUNDEF;
  2390.     if (S_ISREG(PL_statcache.st_mode))
  2391.     RETPUSHYES;
  2392.     RETPUSHNO;
  2393. }
  2394.  
  2395. PP(pp_ftdir)
  2396. {
  2397.     I32 result = my_stat(ARGS);
  2398.     djSP;
  2399.     if (result < 0)
  2400.     RETPUSHUNDEF;
  2401.     if (S_ISDIR(PL_statcache.st_mode))
  2402.     RETPUSHYES;
  2403.     RETPUSHNO;
  2404. }
  2405.  
  2406. PP(pp_ftpipe)
  2407. {
  2408.     I32 result = my_stat(ARGS);
  2409.     djSP;
  2410.     if (result < 0)
  2411.     RETPUSHUNDEF;
  2412.     if (S_ISFIFO(PL_statcache.st_mode))
  2413.     RETPUSHYES;
  2414.     RETPUSHNO;
  2415. }
  2416.  
  2417. PP(pp_ftlink)
  2418. {
  2419.     I32 result = my_lstat(ARGS);
  2420.     djSP;
  2421.     if (result < 0)
  2422.     RETPUSHUNDEF;
  2423.     if (S_ISLNK(PL_statcache.st_mode))
  2424.     RETPUSHYES;
  2425.     RETPUSHNO;
  2426. }
  2427.  
  2428. PP(pp_ftsuid)
  2429. {
  2430.     djSP;
  2431. #ifdef S_ISUID
  2432.     I32 result = my_stat(ARGS);
  2433.     SPAGAIN;
  2434.     if (result < 0)
  2435.     RETPUSHUNDEF;
  2436.     if (PL_statcache.st_mode & S_ISUID)
  2437.     RETPUSHYES;
  2438. #endif
  2439.     RETPUSHNO;
  2440. }
  2441.  
  2442. PP(pp_ftsgid)
  2443. {
  2444.     djSP;
  2445. #ifdef S_ISGID
  2446.     I32 result = my_stat(ARGS);
  2447.     SPAGAIN;
  2448.     if (result < 0)
  2449.     RETPUSHUNDEF;
  2450.     if (PL_statcache.st_mode & S_ISGID)
  2451.     RETPUSHYES;
  2452. #endif
  2453.     RETPUSHNO;
  2454. }
  2455.  
  2456. PP(pp_ftsvtx)
  2457. {
  2458.     djSP;
  2459. #ifdef S_ISVTX
  2460.     I32 result = my_stat(ARGS);
  2461.     SPAGAIN;
  2462.     if (result < 0)
  2463.     RETPUSHUNDEF;
  2464.     if (PL_statcache.st_mode & S_ISVTX)
  2465.     RETPUSHYES;
  2466. #endif
  2467.     RETPUSHNO;
  2468. }
  2469.  
  2470. PP(pp_fttty)
  2471. {
  2472.     djSP;
  2473.     int fd;
  2474.     GV *gv;
  2475.     char *tmps = Nullch;
  2476.  
  2477.     if (PL_op->op_flags & OPf_REF)
  2478.     gv = cGVOP->op_gv;
  2479.     else if (isGV(TOPs))
  2480.     gv = (GV*)POPs;
  2481.     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
  2482.     gv = (GV*)SvRV(POPs);
  2483.     else
  2484.     gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
  2485.  
  2486.     if (GvIO(gv) && IoIFP(GvIOp(gv)))
  2487.     fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
  2488.     else if (tmps && isDIGIT(*tmps))
  2489.     fd = atoi(tmps);
  2490.     else
  2491.     RETPUSHUNDEF;
  2492.     if (PerlLIO_isatty(fd))
  2493.     RETPUSHYES;
  2494.     RETPUSHNO;
  2495. }
  2496.  
  2497. #if defined(atarist) /* this will work with atariST. Configure will
  2498.             make guesses for other systems. */
  2499. # define FILE_base(f) ((f)->_base)
  2500. # define FILE_ptr(f) ((f)->_ptr)
  2501. # define FILE_cnt(f) ((f)->_cnt)
  2502. # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
  2503. #endif
  2504.  
  2505. PP(pp_fttext)
  2506. {
  2507.     djSP;
  2508.     I32 i;
  2509.     I32 len;
  2510.     I32 odd = 0;
  2511.     STDCHAR tbuf[512];
  2512.     register STDCHAR *s;
  2513.     register IO *io;
  2514.     register SV *sv;
  2515.     GV *gv;
  2516.  
  2517.     if (PL_op->op_flags & OPf_REF)
  2518.     gv = cGVOP->op_gv;
  2519.     else if (isGV(TOPs))
  2520.     gv = (GV*)POPs;
  2521.     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
  2522.     gv = (GV*)SvRV(POPs);
  2523.     else
  2524.     gv = Nullgv;
  2525.  
  2526.     if (gv) {
  2527.     EXTEND(SP, 1);
  2528.     if (gv == PL_defgv) {
  2529.         if (PL_statgv)
  2530.         io = GvIO(PL_statgv);
  2531.         else {
  2532.         sv = PL_statname;
  2533.         goto really_filename;
  2534.         }
  2535.     }
  2536.     else {
  2537.         PL_statgv = gv;
  2538.         PL_laststatval = -1;
  2539.         sv_setpv(PL_statname, "");
  2540.         io = GvIO(PL_statgv);
  2541.     }
  2542.     if (io && IoIFP(io)) {
  2543.         if (! PerlIO_has_base(IoIFP(io)))
  2544.         DIE("-T and -B not implemented on filehandles");
  2545.         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
  2546.         if (PL_laststatval < 0)
  2547.         RETPUSHUNDEF;
  2548.         if (S_ISDIR(PL_statcache.st_mode))    /* handle NFS glitch */
  2549.         if (PL_op->op_type == OP_FTTEXT)
  2550.             RETPUSHNO;
  2551.         else
  2552.             RETPUSHYES;
  2553.         if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
  2554.         i = PerlIO_getc(IoIFP(io));
  2555.         if (i != EOF)
  2556.             (void)PerlIO_ungetc(IoIFP(io),i);
  2557.         }
  2558.         if (PerlIO_get_cnt(IoIFP(io)) <= 0)    /* null file is anything */
  2559.         RETPUSHYES;
  2560.         len = PerlIO_get_bufsiz(IoIFP(io));
  2561.         s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
  2562.         /* sfio can have large buffers - limit to 512 */
  2563.         if (len > 512)
  2564.         len = 512;
  2565.     }
  2566.     else {
  2567.         if (PL_dowarn)
  2568.         warn("Test on unopened file <%s>",
  2569.           GvENAME(cGVOP->op_gv));
  2570.         SETERRNO(EBADF,RMS$_IFI);
  2571.         RETPUSHUNDEF;
  2572.     }
  2573.     }
  2574.     else {
  2575.     sv = POPs;
  2576.       really_filename:
  2577.     PL_statgv = Nullgv;
  2578.     PL_laststatval = -1;
  2579.     sv_setpv(PL_statname, SvPV(sv, PL_na));
  2580. #ifdef HAS_OPEN3
  2581.     i = PerlLIO_open3(SvPV(sv, PL_na), O_RDONLY, 0);
  2582. #else
  2583.     i = PerlLIO_open(SvPV(sv, PL_na), 0);
  2584. #endif
  2585.     if (i < 0) {
  2586.         if (PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
  2587.         warn(warn_nl, "open");
  2588.         RETPUSHUNDEF;
  2589.     }
  2590.     PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
  2591.     if (PL_laststatval < 0)
  2592.         RETPUSHUNDEF;
  2593.     len = PerlLIO_read(i, tbuf, 512);
  2594.     (void)PerlLIO_close(i);
  2595.     if (len <= 0) {
  2596.         if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
  2597.         RETPUSHNO;        /* special case NFS directories */
  2598.         RETPUSHYES;        /* null file is anything */
  2599.     }
  2600.     s = tbuf;
  2601.     }
  2602.  
  2603.     /* now scan s to look for textiness */
  2604.     /*   XXX ASCII dependent code */
  2605.  
  2606.     for (i = 0; i < len; i++, s++) {
  2607.     if (!*s) {            /* null never allowed in text */
  2608.         odd += len;
  2609.         break;
  2610.     }
  2611.     else if (*s & 128)
  2612.         odd++;
  2613.     else if (*s < 32 &&
  2614.       *s != '\n' && *s != '\r' && *s != '\b' &&
  2615.       *s != '\t' && *s != '\f' && *s != 27)
  2616.         odd++;
  2617.     }
  2618.  
  2619.     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
  2620.     RETPUSHNO;
  2621.     else
  2622.     RETPUSHYES;
  2623. }
  2624.  
  2625. PP(pp_ftbinary)
  2626. {
  2627.     return pp_fttext(ARGS);
  2628. }
  2629.  
  2630. /* File calls. */
  2631.  
  2632. PP(pp_chdir)
  2633. {
  2634.     djSP; dTARGET;
  2635.     char *tmps;
  2636.     SV **svp;
  2637.  
  2638.     if (MAXARG < 1)
  2639.     tmps = Nullch;
  2640.     else
  2641.     tmps = POPp;
  2642.     if (!tmps || !*tmps) {
  2643.     svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
  2644.     if (svp)
  2645.         tmps = SvPV(*svp, PL_na);
  2646.     }
  2647.     if (!tmps || !*tmps) {
  2648.     svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
  2649.     if (svp)
  2650.         tmps = SvPV(*svp, PL_na);
  2651.     }
  2652. #ifdef VMS
  2653.     if (!tmps || !*tmps) {
  2654.        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
  2655.        if (svp)
  2656.            tmps = SvPV(*svp, PL_na);
  2657.     }
  2658. #endif
  2659.     TAINT_PROPER("chdir");
  2660.     PUSHi( PerlDir_chdir(tmps) >= 0 );
  2661. #ifdef VMS
  2662.     /* Clear the DEFAULT element of ENV so we'll get the new value
  2663.      * in the future. */
  2664.     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
  2665. #endif
  2666.     RETURN;
  2667. }
  2668.  
  2669. PP(pp_chown)
  2670. {
  2671.     djSP; dMARK; dTARGET;
  2672.     I32 value;
  2673. #ifdef HAS_CHOWN
  2674.     value = (I32)apply(PL_op->op_type, MARK, SP);
  2675.     SP = MARK;
  2676.     PUSHi(value);
  2677.     RETURN;
  2678. #else
  2679.     DIE(no_func, "Unsupported function chown");
  2680. #endif
  2681. }
  2682.  
  2683. PP(pp_chroot)
  2684. {
  2685.     djSP; dTARGET;
  2686.     char *tmps;
  2687. #ifdef HAS_CHROOT
  2688.     tmps = POPp;
  2689.     TAINT_PROPER("chroot");
  2690.     PUSHi( chroot(tmps) >= 0 );
  2691.     RETURN;
  2692. #else
  2693.     DIE(no_func, "chroot");
  2694. #endif
  2695. }
  2696.  
  2697. PP(pp_unlink)
  2698. {
  2699.     djSP; dMARK; dTARGET;
  2700.     I32 value;
  2701.     value = (I32)apply(PL_op->op_type, MARK, SP);
  2702.     SP = MARK;
  2703.     PUSHi(value);
  2704.     RETURN;
  2705. }
  2706.  
  2707. PP(pp_chmod)
  2708. {
  2709.     djSP; dMARK; dTARGET;
  2710.     I32 value;
  2711.     value = (I32)apply(PL_op->op_type, MARK, SP);
  2712.     SP = MARK;
  2713.     PUSHi(value);
  2714.     RETURN;
  2715. }
  2716.  
  2717. PP(pp_utime)
  2718. {
  2719.     djSP; dMARK; dTARGET;
  2720.     I32 value;
  2721.     value = (I32)apply(PL_op->op_type, MARK, SP);
  2722.     SP = MARK;
  2723.     PUSHi(value);
  2724.     RETURN;
  2725. }
  2726.  
  2727. PP(pp_rename)
  2728. {
  2729.     djSP; dTARGET;
  2730.     int anum;
  2731.  
  2732.     char *tmps2 = POPp;
  2733.     char *tmps = SvPV(TOPs, PL_na);
  2734.     TAINT_PROPER("rename");
  2735. #ifdef HAS_RENAME
  2736.     anum = PerlLIO_rename(tmps, tmps2);
  2737. #else
  2738.     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
  2739.     if (same_dirent(tmps2, tmps))    /* can always rename to same name */
  2740.         anum = 1;
  2741.     else {
  2742.         if (euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
  2743.         (void)UNLINK(tmps2);
  2744.         if (!(anum = link(tmps, tmps2)))
  2745.         anum = UNLINK(tmps);
  2746.     }
  2747.     }
  2748. #endif
  2749.     SETi( anum >= 0 );
  2750.     RETURN;
  2751. }
  2752.  
  2753. PP(pp_link)
  2754. {
  2755.     djSP; dTARGET;
  2756. #ifdef HAS_LINK
  2757.     char *tmps2 = POPp;
  2758.     char *tmps = SvPV(TOPs, PL_na);
  2759.     TAINT_PROPER("link");
  2760.     SETi( link(tmps, tmps2) >= 0 );
  2761. #else
  2762.     DIE(no_func, "Unsupported function link");
  2763. #endif
  2764.     RETURN;
  2765. }
  2766.  
  2767. PP(pp_symlink)
  2768. {
  2769.     djSP; dTARGET;
  2770. #ifdef HAS_SYMLINK
  2771.     char *tmps2 = POPp;
  2772.     char *tmps = SvPV(TOPs, PL_na);
  2773.     TAINT_PROPER("symlink");
  2774.     SETi( symlink(tmps, tmps2) >= 0 );
  2775.     RETURN;
  2776. #else
  2777.     DIE(no_func, "symlink");
  2778. #endif
  2779. }
  2780.  
  2781. PP(pp_readlink)
  2782. {
  2783.     djSP; dTARGET;
  2784. #ifdef HAS_SYMLINK
  2785.     char *tmps;
  2786.     char buf[MAXPATHLEN];
  2787.     int len;
  2788.  
  2789. #ifndef INCOMPLETE_TAINTS
  2790.     TAINT;
  2791. #endif
  2792.     tmps = POPp;
  2793.     len = readlink(tmps, buf, sizeof buf);
  2794.     EXTEND(SP, 1);
  2795.     if (len < 0)
  2796.     RETPUSHUNDEF;
  2797.     PUSHp(buf, len);
  2798.     RETURN;
  2799. #else
  2800.     EXTEND(SP, 1);
  2801.     RETSETUNDEF;        /* just pretend it's a normal file */
  2802. #endif
  2803. }
  2804.  
  2805. #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
  2806. static int
  2807. dooneliner(cmd, filename)
  2808. char *cmd;
  2809. char *filename;
  2810. {
  2811.     char *save_filename = filename;
  2812.     char *cmdline;
  2813.     char *s;
  2814.     PerlIO *myfp;
  2815.     int anum = 1;
  2816.  
  2817.     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
  2818.     strcpy(cmdline, cmd);
  2819.     strcat(cmdline, " ");
  2820.     for (s = cmdline + strlen(cmdline); *filename; ) {
  2821.     *s++ = '\\';
  2822.     *s++ = *filename++;
  2823.     }
  2824.     strcpy(s, " 2>&1");
  2825.     myfp = PerlProc_popen(cmdline, "r");
  2826.     Safefree(cmdline);
  2827.  
  2828.     if (myfp) {
  2829.     SV *tmpsv = sv_newmortal();
  2830.     /* Need to save/restore 'PL_rs' ?? */
  2831.     s = sv_gets(tmpsv, myfp, 0);
  2832.     (void)PerlProc_pclose(myfp);
  2833.     if (s != Nullch) {
  2834.         int e;
  2835.         for (e = 1;
  2836. #ifdef HAS_SYS_ERRLIST
  2837.          e <= sys_nerr
  2838. #endif
  2839.          ; e++)
  2840.         {
  2841.         /* you don't see this */
  2842.         char *errmsg =
  2843. #ifdef HAS_SYS_ERRLIST
  2844.             sys_errlist[e]
  2845. #else
  2846.             strerror(e)
  2847. #endif
  2848.             ;
  2849.         if (!errmsg)
  2850.             break;
  2851.         if (instr(s, errmsg)) {
  2852.             SETERRNO(e,0);
  2853.             return 0;
  2854.         }
  2855.         }
  2856.         SETERRNO(0,0);
  2857. #ifndef EACCES
  2858. #define EACCES EPERM
  2859. #endif
  2860.         if (instr(s, "cannot make"))
  2861.         SETERRNO(EEXIST,RMS$_FEX);
  2862.         else if (instr(s, "existing file"))
  2863.         SETERRNO(EEXIST,RMS$_FEX);
  2864.         else if (instr(s, "ile exists"))
  2865.         SETERRNO(EEXIST,RMS$_FEX);
  2866.         else if (instr(s, "non-exist"))
  2867.         SETERRNO(ENOENT,RMS$_FNF);
  2868.         else if (instr(s, "does not exist"))
  2869.         SETERRNO(ENOENT,RMS$_FNF);
  2870.         else if (instr(s, "not empty"))
  2871.         SETERRNO(EBUSY,SS$_DEVOFFLINE);
  2872.         else if (instr(s, "cannot access"))
  2873.         SETERRNO(EACCES,RMS$_PRV);
  2874.         else
  2875.         SETERRNO(EPERM,RMS$_PRV);
  2876.         return 0;
  2877.     }
  2878.     else {    /* some mkdirs return no failure indication */
  2879.         anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
  2880.         if (PL_op->op_type == OP_RMDIR)
  2881.         anum = !anum;
  2882.         if (anum)
  2883.         SETERRNO(0,0);
  2884.         else
  2885.         SETERRNO(EACCES,RMS$_PRV);    /* a guess */
  2886.     }
  2887.     return anum;
  2888.     }
  2889.     else
  2890.     return 0;
  2891. }
  2892. #endif
  2893.  
  2894. PP(pp_mkdir)
  2895. {
  2896.     djSP; dTARGET;
  2897.     int mode = POPi;
  2898. #ifndef HAS_MKDIR
  2899.     int oldumask;
  2900. #endif
  2901.     char *tmps = SvPV(TOPs, PL_na);
  2902.  
  2903.     TAINT_PROPER("mkdir");
  2904. #ifdef HAS_MKDIR
  2905.     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
  2906. #else
  2907.     SETi( dooneliner("mkdir", tmps) );
  2908.     oldumask = PerlLIO_umask(0);
  2909.     PerlLIO_umask(oldumask);
  2910.     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
  2911. #endif
  2912.     RETURN;
  2913. }
  2914.  
  2915. PP(pp_rmdir)
  2916. {
  2917.     djSP; dTARGET;
  2918.     char *tmps;
  2919.  
  2920.     tmps = POPp;
  2921.     TAINT_PROPER("rmdir");
  2922. #ifdef HAS_RMDIR
  2923.     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
  2924. #else
  2925.     XPUSHi( dooneliner("rmdir", tmps) );
  2926. #endif
  2927.     RETURN;
  2928. }
  2929.  
  2930. /* Directory calls. */
  2931.  
  2932. PP(pp_open_dir)
  2933. {
  2934.     djSP;
  2935. #if defined(Direntry_t) && defined(HAS_READDIR)
  2936.     char *dirname = POPp;
  2937.     GV *gv = (GV*)POPs;
  2938.     register IO *io = GvIOn(gv);
  2939.  
  2940.     if (!io)
  2941.     goto nope;
  2942.  
  2943.     if (IoDIRP(io))
  2944.     PerlDir_close(IoDIRP(io));
  2945.     if (!(IoDIRP(io) = PerlDir_open(dirname)))
  2946.     goto nope;
  2947.  
  2948.     RETPUSHYES;
  2949. nope:
  2950.     if (!errno)
  2951.     SETERRNO(EBADF,RMS$_DIR);
  2952.     RETPUSHUNDEF;
  2953. #else
  2954.     DIE(no_dir_func, "opendir");
  2955. #endif
  2956. }
  2957.  
  2958. PP(pp_readdir)
  2959. {
  2960.     djSP;
  2961. #if defined(Direntry_t) && defined(HAS_READDIR)
  2962. #ifndef I_DIRENT
  2963.     Direntry_t *readdir _((DIR *));
  2964. #endif
  2965.     register Direntry_t *dp;
  2966.     GV *gv = (GV*)POPs;
  2967.     register IO *io = GvIOn(gv);
  2968.     SV *sv;
  2969.  
  2970.     if (!io || !IoDIRP(io))
  2971.     goto nope;
  2972.  
  2973.     if (GIMME == G_ARRAY) {
  2974.     /*SUPPRESS 560*/
  2975.     while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
  2976. #ifdef DIRNAMLEN
  2977.         sv = newSVpv(dp->d_name, dp->d_namlen);
  2978. #else
  2979.         sv = newSVpv(dp->d_name, 0);
  2980. #endif
  2981. #ifndef INCOMPLETE_TAINTS
  2982.           SvTAINTED_on(sv);
  2983. #endif
  2984.         XPUSHs(sv_2mortal(sv));
  2985.     }
  2986.     }
  2987.     else {
  2988.     if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
  2989.         goto nope;
  2990. #ifdef DIRNAMLEN
  2991.     sv = newSVpv(dp->d_name, dp->d_namlen);
  2992. #else
  2993.     sv = newSVpv(dp->d_name, 0);
  2994. #endif
  2995. #ifndef INCOMPLETE_TAINTS
  2996.     SvTAINTED_on(sv);
  2997. #endif
  2998.     XPUSHs(sv_2mortal(sv));
  2999.     }
  3000.     RETURN;
  3001.  
  3002. nope:
  3003.     if (!errno)
  3004.     SETERRNO(EBADF,RMS$_ISI);
  3005.     if (GIMME == G_ARRAY)
  3006.     RETURN;
  3007.     else
  3008.     RETPUSHUNDEF;
  3009. #else
  3010.     DIE(no_dir_func, "readdir");
  3011. #endif
  3012. }
  3013.  
  3014. PP(pp_telldir)
  3015. {
  3016.     djSP; dTARGET;
  3017. #if defined(HAS_TELLDIR) || defined(telldir)
  3018. # ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
  3019.     long telldir _((DIR *));
  3020. # endif
  3021.     GV *gv = (GV*)POPs;
  3022.     register IO *io = GvIOn(gv);
  3023.  
  3024.     if (!io || !IoDIRP(io))
  3025.     goto nope;
  3026.  
  3027.     PUSHi( PerlDir_tell(IoDIRP(io)) );
  3028.     RETURN;
  3029. nope:
  3030.     if (!errno)
  3031.     SETERRNO(EBADF,RMS$_ISI);
  3032.     RETPUSHUNDEF;
  3033. #else
  3034.     DIE(no_dir_func, "telldir");
  3035. #endif
  3036. }
  3037.  
  3038. PP(pp_seekdir)
  3039. {
  3040.     djSP;
  3041. #if defined(HAS_SEEKDIR) || defined(seekdir)
  3042.     long along = POPl;
  3043.     GV *gv = (GV*)POPs;
  3044.     register IO *io = GvIOn(gv);
  3045.  
  3046.     if (!io || !IoDIRP(io))
  3047.     goto nope;
  3048.  
  3049.     (void)PerlDir_seek(IoDIRP(io), along);
  3050.  
  3051.     RETPUSHYES;
  3052. nope:
  3053.     if (!errno)
  3054.     SETERRNO(EBADF,RMS$_ISI);
  3055.     RETPUSHUNDEF;
  3056. #else
  3057.     DIE(no_dir_func, "seekdir");
  3058. #endif
  3059. }
  3060.  
  3061. PP(pp_rewinddir)
  3062. {
  3063.     djSP;
  3064. #if defined(HAS_REWINDDIR) || defined(rewinddir)
  3065.     GV *gv = (GV*)POPs;
  3066.     register IO *io = GvIOn(gv);
  3067.  
  3068.     if (!io || !IoDIRP(io))
  3069.     goto nope;
  3070.  
  3071.     (void)PerlDir_rewind(IoDIRP(io));
  3072.     RETPUSHYES;
  3073. nope:
  3074.     if (!errno)
  3075.     SETERRNO(EBADF,RMS$_ISI);
  3076.     RETPUSHUNDEF;
  3077. #else
  3078.     DIE(no_dir_func, "rewinddir");
  3079. #endif
  3080. }
  3081.  
  3082. PP(pp_closedir)
  3083. {
  3084.     djSP;
  3085. #if defined(Direntry_t) && defined(HAS_READDIR)
  3086.     GV *gv = (GV*)POPs;
  3087.     register IO *io = GvIOn(gv);
  3088.  
  3089.     if (!io || !IoDIRP(io))
  3090.     goto nope;
  3091.  
  3092. #ifdef VOID_CLOSEDIR
  3093.     PerlDir_close(IoDIRP(io));
  3094. #else
  3095.     if (PerlDir_close(IoDIRP(io)) < 0) {
  3096.     IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
  3097.     goto nope;
  3098.     }
  3099. #endif
  3100.     IoDIRP(io) = 0;
  3101.  
  3102.     RETPUSHYES;
  3103. nope:
  3104.     if (!errno)
  3105.     SETERRNO(EBADF,RMS$_IFI);
  3106.     RETPUSHUNDEF;
  3107. #else
  3108.     DIE(no_dir_func, "closedir");
  3109. #endif
  3110. }
  3111.  
  3112. /* Process control. */
  3113.  
  3114. PP(pp_fork)
  3115. {
  3116. #ifdef HAS_FORK
  3117.     djSP; dTARGET;
  3118.     int childpid;
  3119.     GV *tmpgv;
  3120.  
  3121.     EXTEND(SP, 1);
  3122.     childpid = fork();
  3123.     if (childpid < 0)
  3124.     RETSETUNDEF;
  3125.     if (!childpid) {
  3126.     /*SUPPRESS 560*/
  3127.     if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
  3128.         sv_setiv(GvSV(tmpgv), (IV)getpid());
  3129.     hv_clear(PL_pidstatus);    /* no kids, so don't wait for 'em */
  3130.     }
  3131.     PUSHi(childpid);
  3132.     RETURN;
  3133. #else
  3134.     DIE(no_func, "Unsupported function fork");
  3135. #endif
  3136. }
  3137.  
  3138. PP(pp_wait)
  3139. {
  3140. #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
  3141.     djSP; dTARGET;
  3142.     int childpid;
  3143.     int argflags;
  3144.  
  3145.     childpid = wait4pid(-1, &argflags, 0);
  3146.     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
  3147.     XPUSHi(childpid);
  3148.     RETURN;
  3149. #else
  3150.     DIE(no_func, "Unsupported function wait");
  3151. #endif
  3152. }
  3153.  
  3154. PP(pp_waitpid)
  3155. {
  3156. #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
  3157.     djSP; dTARGET;
  3158.     int childpid;
  3159.     int optype;
  3160.     int argflags;
  3161.  
  3162.     optype = POPi;
  3163.     childpid = TOPi;
  3164.     childpid = wait4pid(childpid, &argflags, optype);
  3165.     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
  3166.     SETi(childpid);
  3167.     RETURN;
  3168. #else
  3169.     DIE(no_func, "Unsupported function waitpid");
  3170. #endif
  3171. }
  3172.  
  3173. PP(pp_system)
  3174. {
  3175.     djSP; dMARK; dORIGMARK; dTARGET;
  3176.     I32 value;
  3177.     int childpid;
  3178.     int result;
  3179.     int status;
  3180.     Sigsave_t ihand,qhand;     /* place to save signals during system() */
  3181.  
  3182.     if (SP - MARK == 1) {
  3183.     if (PL_tainting) {
  3184.         char *junk = SvPV(TOPs, PL_na);
  3185.         TAINT_ENV();
  3186.         TAINT_PROPER("system");
  3187.     }
  3188.     }
  3189. #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
  3190.     while ((childpid = vfork()) == -1) {
  3191.     if (errno != EAGAIN) {
  3192.         value = -1;
  3193.         SP = ORIGMARK;
  3194.         PUSHi(value);
  3195.         RETURN;
  3196.     }
  3197.     sleep(5);
  3198.     }
  3199.     if (childpid > 0) {
  3200.     rsignal_save(SIGINT, SIG_IGN, &ihand);
  3201.     rsignal_save(SIGQUIT, SIG_IGN, &qhand);
  3202.     do {
  3203.         result = wait4pid(childpid, &status, 0);
  3204.     } while (result == -1 && errno == EINTR);
  3205.     (void)rsignal_restore(SIGINT, &ihand);
  3206.     (void)rsignal_restore(SIGQUIT, &qhand);
  3207.     STATUS_NATIVE_SET(result == -1 ? -1 : status);
  3208.     do_execfree();    /* free any memory child malloced on vfork */
  3209.     SP = ORIGMARK;
  3210.     PUSHi(STATUS_CURRENT);
  3211.     RETURN;
  3212.     }
  3213.     if (PL_op->op_flags & OPf_STACKED) {
  3214.     SV *really = *++MARK;
  3215.     value = (I32)do_aexec(really, MARK, SP);
  3216.     }
  3217.     else if (SP - MARK != 1)
  3218.     value = (I32)do_aexec(Nullsv, MARK, SP);
  3219.     else {
  3220.     value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
  3221.     }
  3222.     PerlProc__exit(-1);
  3223. #else /* ! FORK or VMS or OS/2 */
  3224.     if (PL_op->op_flags & OPf_STACKED) {
  3225.     SV *really = *++MARK;
  3226.     value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
  3227.     }
  3228.     else if (SP - MARK != 1)
  3229.     value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
  3230.     else {
  3231.     value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
  3232.     }
  3233.     STATUS_NATIVE_SET(value);
  3234.     do_execfree();
  3235.     SP = ORIGMARK;
  3236.     PUSHi(STATUS_CURRENT);
  3237. #endif /* !FORK or VMS */
  3238.     RETURN;
  3239. }
  3240.  
  3241. PP(pp_exec)
  3242. {
  3243.     djSP; dMARK; dORIGMARK; dTARGET;
  3244.     I32 value;
  3245.  
  3246.     if (PL_op->op_flags & OPf_STACKED) {
  3247.     SV *really = *++MARK;
  3248.     value = (I32)do_aexec(really, MARK, SP);
  3249.     }
  3250.     else if (SP - MARK != 1)
  3251. #ifdef VMS
  3252.     value = (I32)vms_do_aexec(Nullsv, MARK, SP);
  3253. #else
  3254.     value = (I32)do_aexec(Nullsv, MARK, SP);
  3255. #endif
  3256.     else {
  3257.     if (PL_tainting) {
  3258.         char *junk = SvPV(*SP, PL_na);
  3259.         TAINT_ENV();
  3260.         TAINT_PROPER("exec");
  3261.     }
  3262. #ifdef VMS
  3263.     value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
  3264. #else
  3265.     value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
  3266. #endif
  3267.     }
  3268.     SP = ORIGMARK;
  3269.     PUSHi(value);
  3270.     RETURN;
  3271. }
  3272.  
  3273. PP(pp_kill)
  3274. {
  3275.     djSP; dMARK; dTARGET;
  3276.     I32 value;
  3277. #ifdef HAS_KILL
  3278.     value = (I32)apply(PL_op->op_type, MARK, SP);
  3279.     SP = MARK;
  3280.     PUSHi(value);
  3281.     RETURN;
  3282. #else
  3283.     DIE(no_func, "Unsupported function kill");
  3284. #endif
  3285. }
  3286.  
  3287. PP(pp_getppid)
  3288. {
  3289. #ifdef HAS_GETPPID
  3290.     djSP; dTARGET;
  3291.     XPUSHi( getppid() );
  3292.     RETURN;
  3293. #else
  3294.     DIE(no_func, "getppid");
  3295. #endif
  3296. }
  3297.  
  3298. PP(pp_getpgrp)
  3299. {
  3300. #ifdef HAS_GETPGRP
  3301.     djSP; dTARGET;
  3302.     int pid;
  3303.     I32 value;
  3304.  
  3305.     if (MAXARG < 1)
  3306.     pid = 0;
  3307.     else
  3308.     pid = SvIVx(POPs);
  3309. #ifdef BSD_GETPGRP
  3310.     value = (I32)BSD_GETPGRP(pid);
  3311. #else
  3312.     if (pid != 0 && pid != getpid())
  3313.     DIE("POSIX getpgrp can't take an argument");
  3314.     value = (I32)getpgrp();
  3315. #endif
  3316.     XPUSHi(value);
  3317.     RETURN;
  3318. #else
  3319.     DIE(no_func, "getpgrp()");
  3320. #endif
  3321. }
  3322.  
  3323. PP(pp_setpgrp)
  3324. {
  3325. #ifdef HAS_SETPGRP
  3326.     djSP; dTARGET;
  3327.     int pgrp;
  3328.     int pid;
  3329.     if (MAXARG < 2) {
  3330.     pgrp = 0;
  3331.     pid = 0;
  3332.     }
  3333.     else {
  3334.     pgrp = POPi;
  3335.     pid = TOPi;
  3336.     }
  3337.  
  3338.     TAINT_PROPER("setpgrp");
  3339. #ifdef BSD_SETPGRP
  3340.     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
  3341. #else
  3342.     if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
  3343.     DIE("POSIX setpgrp can't take an argument");
  3344.     SETi( setpgrp() >= 0 );
  3345. #endif /* USE_BSDPGRP */
  3346.     RETURN;
  3347. #else
  3348.     DIE(no_func, "setpgrp()");
  3349. #endif
  3350. }
  3351.  
  3352. PP(pp_getpriority)
  3353. {
  3354.     djSP; dTARGET;
  3355.     int which;
  3356.     int who;
  3357. #ifdef HAS_GETPRIORITY
  3358.     who = POPi;
  3359.     which = TOPi;
  3360.     SETi( getpriority(which, who) );
  3361.     RETURN;
  3362. #else
  3363.     DIE(no_func, "getpriority()");
  3364. #endif
  3365. }
  3366.  
  3367. PP(pp_setpriority)
  3368. {
  3369.     djSP; dTARGET;
  3370.     int which;
  3371.     int who;
  3372.     int niceval;
  3373. #ifdef HAS_SETPRIORITY
  3374.     niceval = POPi;
  3375.     who = POPi;
  3376.     which = TOPi;
  3377.     TAINT_PROPER("setpriority");
  3378.     SETi( setpriority(which, who, niceval) >= 0 );
  3379.     RETURN;
  3380. #else
  3381.     DIE(no_func, "setpriority()");
  3382. #endif
  3383. }
  3384.  
  3385. /* Time calls. */
  3386.  
  3387. PP(pp_time)
  3388. {
  3389.     djSP; dTARGET;
  3390. #ifdef BIG_TIME
  3391.     XPUSHn( time(Null(Time_t*)) );
  3392. #else
  3393.     XPUSHi( time(Null(Time_t*)) );
  3394. #endif
  3395.     RETURN;
  3396. }
  3397.  
  3398. /* XXX The POSIX name is CLK_TCK; it is to be preferred
  3399.    to HZ.  Probably.  For now, assume that if the system
  3400.    defines HZ, it does so correctly.  (Will this break
  3401.    on VMS?)
  3402.    Probably we ought to use _sysconf(_SC_CLK_TCK), if
  3403.    it's supported.    --AD  9/96.
  3404. */
  3405.  
  3406. #ifndef HZ
  3407. #  ifdef CLK_TCK
  3408. #    define HZ CLK_TCK
  3409. #  else
  3410. #    define HZ 60
  3411. #  endif
  3412. #endif
  3413.  
  3414. PP(pp_tms)
  3415. {
  3416.     djSP;
  3417.  
  3418. #ifndef HAS_TIMES
  3419.     DIE("times not implemented");
  3420. #else
  3421.     EXTEND(SP, 4);
  3422.  
  3423. #ifndef VMS
  3424.     (void)PerlProc_times(&PL_timesbuf);
  3425. #else
  3426.     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
  3427.                                                    /* struct tms, though same data   */
  3428.                                                    /* is returned.                   */
  3429. #endif
  3430.  
  3431.     PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
  3432.     if (GIMME == G_ARRAY) {
  3433.     PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
  3434.     PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
  3435.     PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
  3436.     }
  3437.     RETURN;
  3438. #endif /* HAS_TIMES */
  3439. }
  3440.  
  3441. PP(pp_localtime)
  3442. {
  3443.     return pp_gmtime(ARGS);
  3444. }
  3445.  
  3446. PP(pp_gmtime)
  3447. {
  3448.     djSP;
  3449.     Time_t when;
  3450.     struct tm *tmbuf;
  3451.     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
  3452.     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
  3453.                   "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
  3454.  
  3455.     if (MAXARG < 1)
  3456.     (void)time(&when);
  3457.     else
  3458. #ifdef BIG_TIME
  3459.     when = (Time_t)SvNVx(POPs);
  3460. #else
  3461.     when = (Time_t)SvIVx(POPs);
  3462. #endif
  3463.  
  3464.     if (PL_op->op_type == OP_LOCALTIME)
  3465.     tmbuf = localtime(&when);
  3466.     else
  3467.     tmbuf = gmtime(&when);
  3468.  
  3469.     EXTEND(SP, 9);
  3470.     EXTEND_MORTAL(9);
  3471.     if (GIMME != G_ARRAY) {
  3472.     dTARGET;
  3473.     SV *tsv;
  3474.     if (!tmbuf)
  3475.         RETPUSHUNDEF;
  3476.     tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
  3477.                dayname[tmbuf->tm_wday],
  3478.                monname[tmbuf->tm_mon],
  3479.                tmbuf->tm_mday,
  3480.                tmbuf->tm_hour,
  3481.                tmbuf->tm_min,
  3482.                tmbuf->tm_sec,
  3483.                tmbuf->tm_year + 1900);
  3484.     PUSHs(sv_2mortal(tsv));
  3485.     }
  3486.     else if (tmbuf) {
  3487.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
  3488.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
  3489.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
  3490.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
  3491.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
  3492.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
  3493.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
  3494.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
  3495.     PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
  3496.     }
  3497.     RETURN;
  3498. }
  3499.  
  3500. PP(pp_alarm)
  3501. {
  3502.     djSP; dTARGET;
  3503.     int anum;
  3504. #ifdef HAS_ALARM
  3505.     anum = POPi;
  3506.     anum = alarm((unsigned int)anum);
  3507.     EXTEND(SP, 1);
  3508.     if (anum < 0)
  3509.     RETPUSHUNDEF;
  3510.     PUSHi((I32)anum);
  3511.     RETURN;
  3512. #else
  3513.     DIE(no_func, "Unsupported function alarm");
  3514. #endif
  3515. }
  3516.  
  3517. PP(pp_sleep)
  3518. {
  3519.     djSP; dTARGET;
  3520.     I32 duration;
  3521.     Time_t lasttime;
  3522.     Time_t when;
  3523.  
  3524.     (void)time(&lasttime);
  3525.     if (MAXARG < 1)
  3526.     PerlProc_pause();
  3527.     else {
  3528.     duration = POPi;
  3529.     PerlProc_sleep((unsigned int)duration);
  3530.     }
  3531.     (void)time(&when);
  3532.     XPUSHi(when - lasttime);
  3533.     RETURN;
  3534. }
  3535.  
  3536. /* Shared memory. */
  3537.  
  3538. PP(pp_shmget)
  3539. {
  3540.     return pp_semget(ARGS);
  3541. }
  3542.  
  3543. PP(pp_shmctl)
  3544. {
  3545.     return pp_semctl(ARGS);
  3546. }
  3547.  
  3548. PP(pp_shmread)
  3549. {
  3550.     return pp_shmwrite(ARGS);
  3551. }
  3552.  
  3553. PP(pp_shmwrite)
  3554. {
  3555. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  3556.     djSP; dMARK; dTARGET;
  3557.     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
  3558.     SP = MARK;
  3559.     PUSHi(value);
  3560.     RETURN;
  3561. #else
  3562.     return pp_semget(ARGS);
  3563. #endif
  3564. }
  3565.  
  3566. /* Message passing. */
  3567.  
  3568. PP(pp_msgget)
  3569. {
  3570.     return pp_semget(ARGS);
  3571. }
  3572.  
  3573. PP(pp_msgctl)
  3574. {
  3575.     return pp_semctl(ARGS);
  3576. }
  3577.  
  3578. PP(pp_msgsnd)
  3579. {
  3580. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  3581.     djSP; dMARK; dTARGET;
  3582.     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
  3583.     SP = MARK;
  3584.     PUSHi(value);
  3585.     RETURN;
  3586. #else
  3587.     return pp_semget(ARGS);
  3588. #endif
  3589. }
  3590.  
  3591. PP(pp_msgrcv)
  3592. {
  3593. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  3594.     djSP; dMARK; dTARGET;
  3595.     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
  3596.     SP = MARK;
  3597.     PUSHi(value);
  3598.     RETURN;
  3599. #else
  3600.     return pp_semget(ARGS);
  3601. #endif
  3602. }
  3603.  
  3604. /* Semaphores. */
  3605.  
  3606. PP(pp_semget)
  3607. {
  3608. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  3609.     djSP; dMARK; dTARGET;
  3610.     int anum = do_ipcget(PL_op->op_type, MARK, SP);
  3611.     SP = MARK;
  3612.     if (anum == -1)
  3613.     RETPUSHUNDEF;
  3614.     PUSHi(anum);
  3615.     RETURN;
  3616. #else
  3617.     DIE("System V IPC is not implemented on this machine");
  3618. #endif
  3619. }
  3620.  
  3621. PP(pp_semctl)
  3622. {
  3623. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  3624.     djSP; dMARK; dTARGET;
  3625.     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
  3626.     SP = MARK;
  3627.     if (anum == -1)
  3628.     RETSETUNDEF;
  3629.     if (anum != 0) {
  3630.     PUSHi(anum);
  3631.     }
  3632.     else {
  3633.     PUSHp(zero_but_true, ZBTLEN);
  3634.     }
  3635.     RETURN;
  3636. #else
  3637.     return pp_semget(ARGS);
  3638. #endif
  3639. }
  3640.  
  3641. PP(pp_semop)
  3642. {
  3643. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  3644.     djSP; dMARK; dTARGET;
  3645.     I32 value = (I32)(do_semop(MARK, SP) >= 0);
  3646.     SP = MARK;
  3647.     PUSHi(value);
  3648.     RETURN;
  3649. #else
  3650.     return pp_semget(ARGS);
  3651. #endif
  3652. }
  3653.  
  3654. /* Get system info. */
  3655.  
  3656. PP(pp_ghbyname)
  3657. {
  3658. #ifdef HAS_GETHOSTBYNAME
  3659.     return pp_ghostent(ARGS);
  3660. #else
  3661.     DIE(no_sock_func, "gethostbyname");
  3662. #endif
  3663. }
  3664.  
  3665. PP(pp_ghbyaddr)
  3666. {
  3667. #ifdef HAS_GETHOSTBYADDR
  3668.     return pp_ghostent(ARGS);
  3669. #else
  3670.     DIE(no_sock_func, "gethostbyaddr");
  3671. #endif
  3672. }
  3673.  
  3674. PP(pp_ghostent)
  3675. {
  3676.     djSP;
  3677. #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
  3678.     I32 which = PL_op->op_type;
  3679.     register char **elem;
  3680.     register SV *sv;
  3681. #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
  3682.     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
  3683.     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
  3684.     struct hostent *PerlSock_gethostent(void);
  3685. #endif
  3686.     struct hostent *hent;
  3687.     unsigned long len;
  3688.  
  3689.     EXTEND(SP, 10);
  3690.     if (which == OP_GHBYNAME)
  3691. #ifdef HAS_GETHOSTBYNAME
  3692.     hent = PerlSock_gethostbyname(POPp);
  3693. #else
  3694.     DIE(no_sock_func, "gethostbyname");
  3695. #endif
  3696.     else if (which == OP_GHBYADDR) {
  3697. #ifdef HAS_GETHOSTBYADDR
  3698.     int addrtype = POPi;
  3699.     SV *addrsv = POPs;
  3700.     STRLEN addrlen;
  3701.     Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
  3702.  
  3703.     hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
  3704. #else
  3705.     DIE(no_sock_func, "gethostbyaddr");
  3706. #endif
  3707.     }
  3708.     else
  3709. #ifdef HAS_GETHOSTENT
  3710.     hent = PerlSock_gethostent();
  3711. #else
  3712.     DIE(no_sock_func, "gethostent");
  3713. #endif
  3714.  
  3715. #ifdef HOST_NOT_FOUND
  3716.     if (!hent)
  3717.     STATUS_NATIVE_SET(h_errno);
  3718. #endif
  3719.  
  3720.     if (GIMME != G_ARRAY) {
  3721.     PUSHs(sv = sv_newmortal());
  3722.     if (hent) {
  3723.         if (which == OP_GHBYNAME) {
  3724.         if (hent->h_addr)
  3725.             sv_setpvn(sv, hent->h_addr, hent->h_length);
  3726.         }
  3727.         else
  3728.         sv_setpv(sv, (char*)hent->h_name);
  3729.     }
  3730.     RETURN;
  3731.     }
  3732.  
  3733.     if (hent) {
  3734.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3735.     sv_setpv(sv, (char*)hent->h_name);
  3736.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3737.     for (elem = hent->h_aliases; elem && *elem; elem++) {
  3738.         sv_catpv(sv, *elem);
  3739.         if (elem[1])
  3740.         sv_catpvn(sv, " ", 1);
  3741.     }
  3742.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3743.     sv_setiv(sv, (IV)hent->h_addrtype);
  3744.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3745.     len = hent->h_length;
  3746.     sv_setiv(sv, (IV)len);
  3747. #ifdef h_addr
  3748.     for (elem = hent->h_addr_list; elem && *elem; elem++) {
  3749.         XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3750.         sv_setpvn(sv, *elem, len);
  3751.     }
  3752. #else
  3753.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3754.     if (hent->h_addr)
  3755.         sv_setpvn(sv, hent->h_addr, len);
  3756. #endif /* h_addr */
  3757.     }
  3758.     RETURN;
  3759. #else
  3760.     DIE(no_sock_func, "gethostent");
  3761. #endif
  3762. }
  3763.  
  3764. PP(pp_gnbyname)
  3765. {
  3766. #ifdef HAS_GETNETBYNAME
  3767.     return pp_gnetent(ARGS);
  3768. #else
  3769.     DIE(no_sock_func, "getnetbyname");
  3770. #endif
  3771. }
  3772.  
  3773. PP(pp_gnbyaddr)
  3774. {
  3775. #ifdef HAS_GETNETBYADDR
  3776.     return pp_gnetent(ARGS);
  3777. #else
  3778.     DIE(no_sock_func, "getnetbyaddr");
  3779. #endif
  3780. }
  3781.  
  3782. PP(pp_gnetent)
  3783. {
  3784.     djSP;
  3785. #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
  3786.     I32 which = PL_op->op_type;
  3787.     register char **elem;
  3788.     register SV *sv;
  3789. #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
  3790.     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
  3791.     struct netent *PerlSock_getnetbyname(Netdb_name_t);
  3792.     struct netent *PerlSock_getnetent(void);
  3793. #endif
  3794.     struct netent *nent;
  3795.  
  3796.     if (which == OP_GNBYNAME)
  3797. #ifdef HAS_GETNETBYNAME
  3798.     nent = PerlSock_getnetbyname(POPp);
  3799. #else
  3800.         DIE(no_sock_func, "getnetbyname");
  3801. #endif
  3802.     else if (which == OP_GNBYADDR) {
  3803. #ifdef HAS_GETNETBYADDR
  3804.     int addrtype = POPi;
  3805.     Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
  3806.     nent = PerlSock_getnetbyaddr(addr, addrtype);
  3807. #else
  3808.     DIE(no_sock_func, "getnetbyaddr");
  3809. #endif
  3810.     }
  3811.     else
  3812. #ifdef HAS_GETNETENT
  3813.     nent = PerlSock_getnetent();
  3814. #else
  3815.         DIE(no_sock_func, "getnetent");
  3816. #endif
  3817.  
  3818.     EXTEND(SP, 4);
  3819.     if (GIMME != G_ARRAY) {
  3820.     PUSHs(sv = sv_newmortal());
  3821.     if (nent) {
  3822.         if (which == OP_GNBYNAME)
  3823.         sv_setiv(sv, (IV)nent->n_net);
  3824.         else
  3825.         sv_setpv(sv, nent->n_name);
  3826.     }
  3827.     RETURN;
  3828.     }
  3829.  
  3830.     if (nent) {
  3831.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3832.     sv_setpv(sv, nent->n_name);
  3833.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3834.     for (elem = nent->n_aliases; elem && *elem; elem++) {
  3835.         sv_catpv(sv, *elem);
  3836.         if (elem[1])
  3837.         sv_catpvn(sv, " ", 1);
  3838.     }
  3839.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3840.     sv_setiv(sv, (IV)nent->n_addrtype);
  3841.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3842.     sv_setiv(sv, (IV)nent->n_net);
  3843.     }
  3844.  
  3845.     RETURN;
  3846. #else
  3847.     DIE(no_sock_func, "getnetent");
  3848. #endif
  3849. }
  3850.  
  3851. PP(pp_gpbyname)
  3852. {
  3853. #ifdef HAS_GETPROTOBYNAME
  3854.     return pp_gprotoent(ARGS);
  3855. #else
  3856.     DIE(no_sock_func, "getprotobyname");
  3857. #endif
  3858. }
  3859.  
  3860. PP(pp_gpbynumber)
  3861. {
  3862. #ifdef HAS_GETPROTOBYNUMBER
  3863.     return pp_gprotoent(ARGS);
  3864. #else
  3865.     DIE(no_sock_func, "getprotobynumber");
  3866. #endif
  3867. }
  3868.  
  3869. PP(pp_gprotoent)
  3870. {
  3871.     djSP;
  3872. #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
  3873.     I32 which = PL_op->op_type;
  3874.     register char **elem;
  3875.     register SV *sv;  
  3876. #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
  3877.     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
  3878.     struct protoent *PerlSock_getprotobynumber(int);
  3879.     struct protoent *PerlSock_getprotoent(void);
  3880. #endif
  3881.     struct protoent *pent;
  3882.  
  3883.     if (which == OP_GPBYNAME)
  3884. #ifdef HAS_GETPROTOBYNAME
  3885.     pent = PerlSock_getprotobyname(POPp);
  3886. #else
  3887.     DIE(no_sock_func, "getprotobyname");
  3888. #endif
  3889.     else if (which == OP_GPBYNUMBER)
  3890. #ifdef HAS_GETPROTOBYNUMBER
  3891.     pent = PerlSock_getprotobynumber(POPi);
  3892. #else
  3893.     DIE(no_sock_func, "getprotobynumber");
  3894. #endif
  3895.     else
  3896. #ifdef HAS_GETPROTOENT
  3897.     pent = PerlSock_getprotoent();
  3898. #else
  3899.     DIE(no_sock_func, "getprotoent");
  3900. #endif
  3901.  
  3902.     EXTEND(SP, 3);
  3903.     if (GIMME != G_ARRAY) {
  3904.     PUSHs(sv = sv_newmortal());
  3905.     if (pent) {
  3906.         if (which == OP_GPBYNAME)
  3907.         sv_setiv(sv, (IV)pent->p_proto);
  3908.         else
  3909.         sv_setpv(sv, pent->p_name);
  3910.     }
  3911.     RETURN;
  3912.     }
  3913.  
  3914.     if (pent) {
  3915.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3916.     sv_setpv(sv, pent->p_name);
  3917.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3918.     for (elem = pent->p_aliases; elem && *elem; elem++) {
  3919.         sv_catpv(sv, *elem);
  3920.         if (elem[1])
  3921.         sv_catpvn(sv, " ", 1);
  3922.     }
  3923.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  3924.     sv_setiv(sv, (IV)pent->p_proto);
  3925.     }
  3926.  
  3927.     RETURN;
  3928. #else
  3929.     DIE(no_sock_func, "getprotoent");
  3930. #endif
  3931. }
  3932.  
  3933. PP(pp_gsbyname)
  3934. {
  3935. #ifdef HAS_GETSERVBYNAME
  3936.     return pp_gservent(ARGS);
  3937. #else
  3938.     DIE(no_sock_func, "getservbyname");
  3939. #endif
  3940. }
  3941.  
  3942. PP(pp_gsbyport)
  3943. {
  3944. #ifdef HAS_GETSERVBYPORT
  3945.     return pp_gservent(ARGS);
  3946. #else
  3947.     DIE(no_sock_func, "getservbyport");
  3948. #endif
  3949. }
  3950.  
  3951. PP(pp_gservent)
  3952. {
  3953.     djSP;
  3954. #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
  3955.     I32 which = PL_op->op_type;
  3956.     register char **elem;
  3957.     register SV *sv;
  3958. #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
  3959.     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
  3960.     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
  3961.     struct servent *PerlSock_getservent(void);
  3962. #endif
  3963.     struct servent *sent;
  3964.  
  3965.     if (which == OP_GSBYNAME) {
  3966. #ifdef HAS_GETSERVBYNAME
  3967.     char *proto = POPp;
  3968.     char *name = POPp;
  3969.  
  3970.     if (proto && !*proto)
  3971.         proto = Nullch;
  3972.  
  3973.     sent = PerlSock_getservbyname(name, proto);
  3974. #else
  3975.     DIE(no_sock_func, "getservbyname");
  3976. #endif
  3977.     }
  3978.     else if (which == OP_GSBYPORT) {
  3979. #ifdef HAS_GETSERVBYPORT
  3980.     char *proto = POPp;
  3981.     unsigned short port = POPu;
  3982.  
  3983. #ifdef HAS_HTONS
  3984.     port = PerlSock_htons(port);
  3985. #endif
  3986.     sent = PerlSock_getservbyport(port, proto);
  3987. #else
  3988.     DIE(no_sock_func, "getservbyport");
  3989. #endif
  3990.     }
  3991.     else
  3992. #ifdef HAS_GETSERVENT
  3993.     sent = PerlSock_getservent();
  3994. #else
  3995.     DIE(no_sock_func, "getservent");
  3996. #endif
  3997.  
  3998.     EXTEND(SP, 4);
  3999.     if (GIMME != G_ARRAY) {
  4000.     PUSHs(sv = sv_newmortal());
  4001.     if (sent) {
  4002.         if (which == OP_GSBYNAME) {
  4003. #ifdef HAS_NTOHS
  4004.         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
  4005. #else
  4006.         sv_setiv(sv, (IV)(sent->s_port));
  4007. #endif
  4008.         }
  4009.         else
  4010.         sv_setpv(sv, sent->s_name);
  4011.     }
  4012.     RETURN;
  4013.     }
  4014.  
  4015.     if (sent) {
  4016.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4017.     sv_setpv(sv, sent->s_name);
  4018.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4019.     for (elem = sent->s_aliases; elem && *elem; elem++) {
  4020.         sv_catpv(sv, *elem);
  4021.         if (elem[1])
  4022.         sv_catpvn(sv, " ", 1);
  4023.     }
  4024.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4025. #ifdef HAS_NTOHS
  4026.     sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
  4027. #else
  4028.     sv_setiv(sv, (IV)(sent->s_port));
  4029. #endif
  4030.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4031.     sv_setpv(sv, sent->s_proto);
  4032.     }
  4033.  
  4034.     RETURN;
  4035. #else
  4036.     DIE(no_sock_func, "getservent");
  4037. #endif
  4038. }
  4039.  
  4040. PP(pp_shostent)
  4041. {
  4042.     djSP;
  4043. #ifdef HAS_SETHOSTENT
  4044.     PerlSock_sethostent(TOPi);
  4045.     RETSETYES;
  4046. #else
  4047.     DIE(no_sock_func, "sethostent");
  4048. #endif
  4049. }
  4050.  
  4051. PP(pp_snetent)
  4052. {
  4053.     djSP;
  4054. #ifdef HAS_SETNETENT
  4055.     PerlSock_setnetent(TOPi);
  4056.     RETSETYES;
  4057. #else
  4058.     DIE(no_sock_func, "setnetent");
  4059. #endif
  4060. }
  4061.  
  4062. PP(pp_sprotoent)
  4063. {
  4064.     djSP;
  4065. #ifdef HAS_SETPROTOENT
  4066.     PerlSock_setprotoent(TOPi);
  4067.     RETSETYES;
  4068. #else
  4069.     DIE(no_sock_func, "setprotoent");
  4070. #endif
  4071. }
  4072.  
  4073. PP(pp_sservent)
  4074. {
  4075.     djSP;
  4076. #ifdef HAS_SETSERVENT
  4077.     PerlSock_setservent(TOPi);
  4078.     RETSETYES;
  4079. #else
  4080.     DIE(no_sock_func, "setservent");
  4081. #endif
  4082. }
  4083.  
  4084. PP(pp_ehostent)
  4085. {
  4086.     djSP;
  4087. #ifdef HAS_ENDHOSTENT
  4088.     PerlSock_endhostent();
  4089.     EXTEND(SP,1);
  4090.     RETPUSHYES;
  4091. #else
  4092.     DIE(no_sock_func, "endhostent");
  4093. #endif
  4094. }
  4095.  
  4096. PP(pp_enetent)
  4097. {
  4098.     djSP;
  4099. #ifdef HAS_ENDNETENT
  4100.     PerlSock_endnetent();
  4101.     EXTEND(SP,1);
  4102.     RETPUSHYES;
  4103. #else
  4104.     DIE(no_sock_func, "endnetent");
  4105. #endif
  4106. }
  4107.  
  4108. PP(pp_eprotoent)
  4109. {
  4110.     djSP;
  4111. #ifdef HAS_ENDPROTOENT
  4112.     PerlSock_endprotoent();
  4113.     EXTEND(SP,1);
  4114.     RETPUSHYES;
  4115. #else
  4116.     DIE(no_sock_func, "endprotoent");
  4117. #endif
  4118. }
  4119.  
  4120. PP(pp_eservent)
  4121. {
  4122.     djSP;
  4123. #ifdef HAS_ENDSERVENT
  4124.     PerlSock_endservent();
  4125.     EXTEND(SP,1);
  4126.     RETPUSHYES;
  4127. #else
  4128.     DIE(no_sock_func, "endservent");
  4129. #endif
  4130. }
  4131.  
  4132. PP(pp_gpwnam)
  4133. {
  4134. #ifdef HAS_PASSWD
  4135.     return pp_gpwent(ARGS);
  4136. #else
  4137.     DIE(no_func, "getpwnam");
  4138. #endif
  4139. }
  4140.  
  4141. PP(pp_gpwuid)
  4142. {
  4143. #ifdef HAS_PASSWD
  4144.     return pp_gpwent(ARGS);
  4145. #else
  4146.     DIE(no_func, "getpwuid");
  4147. #endif
  4148. }
  4149.  
  4150. PP(pp_gpwent)
  4151. {
  4152.     djSP;
  4153. #if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
  4154.     I32 which = PL_op->op_type;
  4155.     register SV *sv;
  4156.     struct passwd *pwent;
  4157.  
  4158.     if (which == OP_GPWNAM)
  4159.     pwent = getpwnam(POPp);
  4160.     else if (which == OP_GPWUID)
  4161.     pwent = getpwuid(POPi);
  4162.     else
  4163.     pwent = (struct passwd *)getpwent();
  4164.  
  4165.     EXTEND(SP, 10);
  4166.     if (GIMME != G_ARRAY) {
  4167.     PUSHs(sv = sv_newmortal());
  4168.     if (pwent) {
  4169.         if (which == OP_GPWNAM)
  4170.         sv_setiv(sv, (IV)pwent->pw_uid);
  4171.         else
  4172.         sv_setpv(sv, pwent->pw_name);
  4173.     }
  4174.     RETURN;
  4175.     }
  4176.  
  4177.     if (pwent) {
  4178.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4179.     sv_setpv(sv, pwent->pw_name);
  4180.  
  4181.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4182. #ifdef PWPASSWD
  4183.     sv_setpv(sv, pwent->pw_passwd);
  4184. #endif
  4185.  
  4186.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4187.     sv_setiv(sv, (IV)pwent->pw_uid);
  4188.  
  4189.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4190.     sv_setiv(sv, (IV)pwent->pw_gid);
  4191.  
  4192.     /* pw_change, pw_quota, and pw_age are mutually exclusive. */
  4193.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4194. #ifdef PWCHANGE
  4195.     sv_setiv(sv, (IV)pwent->pw_change);
  4196. #else
  4197. #   ifdef PWQUOTA
  4198.     sv_setiv(sv, (IV)pwent->pw_quota);
  4199. #   else
  4200. #       ifdef PWAGE
  4201.     sv_setpv(sv, pwent->pw_age);
  4202. #       endif
  4203. #   endif
  4204. #endif
  4205.  
  4206.     /* pw_class and pw_comment are mutually exclusive. */
  4207.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4208. #ifdef PWCLASS
  4209.     sv_setpv(sv, pwent->pw_class);
  4210. #else
  4211. #   ifdef PWCOMMENT
  4212.     sv_setpv(sv, pwent->pw_comment);
  4213. #   endif
  4214. #endif
  4215.  
  4216.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4217. #ifdef PWGECOS
  4218.     sv_setpv(sv, pwent->pw_gecos);
  4219. #endif
  4220. #ifndef INCOMPLETE_TAINTS
  4221.     /* pw_gecos is tainted because user himself can diddle with it. */
  4222.     SvTAINTED_on(sv);
  4223. #endif
  4224.  
  4225.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4226.     sv_setpv(sv, pwent->pw_dir);
  4227.  
  4228.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4229.     sv_setpv(sv, pwent->pw_shell);
  4230.  
  4231. #ifdef PWEXPIRE
  4232.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4233.     sv_setiv(sv, (IV)pwent->pw_expire);
  4234. #endif
  4235.     }
  4236.     RETURN;
  4237. #else
  4238.     DIE(no_func, "getpwent");
  4239. #endif
  4240. }
  4241.  
  4242. PP(pp_spwent)
  4243. {
  4244.     djSP;
  4245. #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
  4246.     setpwent();
  4247.     RETPUSHYES;
  4248. #else
  4249.     DIE(no_func, "setpwent");
  4250. #endif
  4251. }
  4252.  
  4253. PP(pp_epwent)
  4254. {
  4255.     djSP;
  4256. #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
  4257.     endpwent();
  4258.     RETPUSHYES;
  4259. #else
  4260.     DIE(no_func, "endpwent");
  4261. #endif
  4262. }
  4263.  
  4264. PP(pp_ggrnam)
  4265. {
  4266. #ifdef HAS_GROUP
  4267.     return pp_ggrent(ARGS);
  4268. #else
  4269.     DIE(no_func, "getgrnam");
  4270. #endif
  4271. }
  4272.  
  4273. PP(pp_ggrgid)
  4274. {
  4275. #ifdef HAS_GROUP
  4276.     return pp_ggrent(ARGS);
  4277. #else
  4278.     DIE(no_func, "getgrgid");
  4279. #endif
  4280. }
  4281.  
  4282. PP(pp_ggrent)
  4283. {
  4284.     djSP;
  4285. #if defined(HAS_GROUP) && defined(HAS_GETGRENT)
  4286.     I32 which = PL_op->op_type;
  4287.     register char **elem;
  4288.     register SV *sv;
  4289.     struct group *grent;
  4290.  
  4291.     if (which == OP_GGRNAM)
  4292.     grent = (struct group *)getgrnam(POPp);
  4293.     else if (which == OP_GGRGID)
  4294.     grent = (struct group *)getgrgid(POPi);
  4295.     else
  4296.     grent = (struct group *)getgrent();
  4297.  
  4298.     EXTEND(SP, 4);
  4299.     if (GIMME != G_ARRAY) {
  4300.     PUSHs(sv = sv_newmortal());
  4301.     if (grent) {
  4302.         if (which == OP_GGRNAM)
  4303.         sv_setiv(sv, (IV)grent->gr_gid);
  4304.         else
  4305.         sv_setpv(sv, grent->gr_name);
  4306.     }
  4307.     RETURN;
  4308.     }
  4309.  
  4310.     if (grent) {
  4311.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4312.     sv_setpv(sv, grent->gr_name);
  4313.  
  4314.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4315. #ifdef GRPASSWD
  4316.     sv_setpv(sv, grent->gr_passwd);
  4317. #endif
  4318.  
  4319.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4320.     sv_setiv(sv, (IV)grent->gr_gid);
  4321.  
  4322.     PUSHs(sv = sv_mortalcopy(&PL_sv_no));
  4323.     for (elem = grent->gr_mem; elem && *elem; elem++) {
  4324.         sv_catpv(sv, *elem);
  4325.         if (elem[1])
  4326.         sv_catpvn(sv, " ", 1);
  4327.     }
  4328.     }
  4329.  
  4330.     RETURN;
  4331. #else
  4332.     DIE(no_func, "getgrent");
  4333. #endif
  4334. }
  4335.  
  4336. PP(pp_sgrent)
  4337. {
  4338.     djSP;
  4339. #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
  4340.     setgrent();
  4341.     RETPUSHYES;
  4342. #else
  4343.     DIE(no_func, "setgrent");
  4344. #endif
  4345. }
  4346.  
  4347. PP(pp_egrent)
  4348. {
  4349.     djSP;
  4350. #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
  4351.     endgrent();
  4352.     RETPUSHYES;
  4353. #else
  4354.     DIE(no_func, "endgrent");
  4355. #endif
  4356. }
  4357.  
  4358. PP(pp_getlogin)
  4359. {
  4360.     djSP; dTARGET;
  4361. #ifdef HAS_GETLOGIN
  4362.     char *tmps;
  4363.     EXTEND(SP, 1);
  4364.     if (!(tmps = PerlProc_getlogin()))
  4365.     RETPUSHUNDEF;
  4366.     PUSHp(tmps, strlen(tmps));
  4367.     RETURN;
  4368. #else
  4369.     DIE(no_func, "getlogin");
  4370. #endif
  4371. }
  4372.  
  4373. /* Miscellaneous. */
  4374.  
  4375. PP(pp_syscall)
  4376. {
  4377. #ifdef HAS_SYSCALL
  4378.     djSP; dMARK; dORIGMARK; dTARGET;
  4379.     register I32 items = SP - MARK;
  4380.     unsigned long a[20];
  4381.     register I32 i = 0;
  4382.     I32 retval = -1;
  4383.     MAGIC *mg;
  4384.  
  4385.     if (PL_tainting) {
  4386.     while (++MARK <= SP) {
  4387.         if (SvTAINTED(*MARK)) {
  4388.         TAINT;
  4389.         break;
  4390.         }
  4391.     }
  4392.     MARK = ORIGMARK;
  4393.     TAINT_PROPER("syscall");
  4394.     }
  4395.  
  4396.     /* This probably won't work on machines where sizeof(long) != sizeof(int)
  4397.      * or where sizeof(long) != sizeof(char*).  But such machines will
  4398.      * not likely have syscall implemented either, so who cares?
  4399.      */
  4400.     while (++MARK <= SP) {
  4401.     if (SvNIOK(*MARK) || !i)
  4402.         a[i++] = SvIV(*MARK);
  4403.     else if (*MARK == &PL_sv_undef)
  4404.         a[i++] = 0;
  4405.     else 
  4406.         a[i++] = (unsigned long)SvPV_force(*MARK, PL_na);
  4407.     if (i > 15)
  4408.         break;
  4409.     }
  4410.     switch (items) {
  4411.     default:
  4412.     DIE("Too many args to syscall");
  4413.     case 0:
  4414.     DIE("Too few args to syscall");
  4415.     case 1:
  4416.     retval = syscall(a[0]);
  4417.     break;
  4418.     case 2:
  4419.     retval = syscall(a[0],a[1]);
  4420.     break;
  4421.     case 3:
  4422.     retval = syscall(a[0],a[1],a[2]);
  4423.     break;
  4424.     case 4:
  4425.     retval = syscall(a[0],a[1],a[2],a[3]);
  4426.     break;
  4427.     case 5:
  4428.     retval = syscall(a[0],a[1],a[2],a[3],a[4]);
  4429.     break;
  4430.     case 6:
  4431.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
  4432.     break;
  4433.     case 7:
  4434.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
  4435.     break;
  4436.     case 8:
  4437.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
  4438.     break;
  4439. #ifdef atarist
  4440.     case 9:
  4441.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
  4442.     break;
  4443.     case 10:
  4444.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
  4445.     break;
  4446.     case 11:
  4447.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
  4448.       a[10]);
  4449.     break;
  4450.     case 12:
  4451.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
  4452.       a[10],a[11]);
  4453.     break;
  4454.     case 13:
  4455.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
  4456.       a[10],a[11],a[12]);
  4457.     break;
  4458.     case 14:
  4459.     retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
  4460.       a[10],a[11],a[12],a[13]);
  4461.     break;
  4462. #endif /* atarist */
  4463.     }
  4464.     SP = ORIGMARK;
  4465.     PUSHi(retval);
  4466.     RETURN;
  4467. #else
  4468.     DIE(no_func, "syscall");
  4469. #endif
  4470. }
  4471.  
  4472. #ifdef FCNTL_EMULATE_FLOCK
  4473.  
  4474. /*  XXX Emulate flock() with fcntl().
  4475.     What's really needed is a good file locking module.
  4476. */
  4477.  
  4478. static int
  4479. fcntl_emulate_flock(int fd, int operation)
  4480. {
  4481.     struct flock flock;
  4482.  
  4483.     switch (operation & ~LOCK_NB) {
  4484.     case LOCK_SH:
  4485.     flock.l_type = F_RDLCK;
  4486.     break;
  4487.     case LOCK_EX:
  4488.     flock.l_type = F_WRLCK;
  4489.     break;
  4490.     case LOCK_UN:
  4491.     flock.l_type = F_UNLCK;
  4492.     break;
  4493.     default:
  4494.     errno = EINVAL;
  4495.     return -1;
  4496.     }
  4497.     flock.l_whence = SEEK_SET;
  4498.     flock.l_start = flock.l_len = 0L;
  4499.  
  4500.     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
  4501. }
  4502.  
  4503. #endif /* FCNTL_EMULATE_FLOCK */
  4504.  
  4505. #ifdef LOCKF_EMULATE_FLOCK
  4506.  
  4507. /*  XXX Emulate flock() with lockf().  This is just to increase
  4508.     portability of scripts.  The calls are not completely
  4509.     interchangeable.  What's really needed is a good file
  4510.     locking module.
  4511. */
  4512.  
  4513. /*  The lockf() constants might have been defined in <unistd.h>.
  4514.     Unfortunately, <unistd.h> causes troubles on some mixed
  4515.     (BSD/POSIX) systems, such as SunOS 4.1.3.
  4516.  
  4517.    Further, the lockf() constants aren't POSIX, so they might not be
  4518.    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
  4519.    just stick in the SVID values and be done with it.  Sigh.
  4520. */
  4521.  
  4522. # ifndef F_ULOCK
  4523. #  define F_ULOCK    0    /* Unlock a previously locked region */
  4524. # endif
  4525. # ifndef F_LOCK
  4526. #  define F_LOCK    1    /* Lock a region for exclusive use */
  4527. # endif
  4528. # ifndef F_TLOCK
  4529. #  define F_TLOCK    2    /* Test and lock a region for exclusive use */
  4530. # endif
  4531. # ifndef F_TEST
  4532. #  define F_TEST    3    /* Test a region for other processes locks */
  4533. # endif
  4534.  
  4535. static int
  4536. lockf_emulate_flock (fd, operation)
  4537. int fd;
  4538. int operation;
  4539. {
  4540.     int i;
  4541.     int save_errno;
  4542.     Off_t pos;
  4543.  
  4544.     /* flock locks entire file so for lockf we need to do the same    */
  4545.     save_errno = errno;
  4546.     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
  4547.     if (pos > 0)    /* is seekable and needs to be repositioned    */
  4548.     if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
  4549.         pos = -1;    /* seek failed, so don't seek back afterwards    */
  4550.     errno = save_errno;
  4551.  
  4552.     switch (operation) {
  4553.  
  4554.     /* LOCK_SH - get a shared lock */
  4555.     case LOCK_SH:
  4556.     /* LOCK_EX - get an exclusive lock */
  4557.     case LOCK_EX:
  4558.         i = lockf (fd, F_LOCK, 0);
  4559.         break;
  4560.  
  4561.     /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
  4562.     case LOCK_SH|LOCK_NB:
  4563.     /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
  4564.     case LOCK_EX|LOCK_NB:
  4565.         i = lockf (fd, F_TLOCK, 0);
  4566.         if (i == -1)
  4567.         if ((errno == EAGAIN) || (errno == EACCES))
  4568.             errno = EWOULDBLOCK;
  4569.         break;
  4570.  
  4571.     /* LOCK_UN - unlock (non-blocking is a no-op) */
  4572.     case LOCK_UN:
  4573.     case LOCK_UN|LOCK_NB:
  4574.         i = lockf (fd, F_ULOCK, 0);
  4575.         break;
  4576.  
  4577.     /* Default - can't decipher operation */
  4578.     default:
  4579.         i = -1;
  4580.         errno = EINVAL;
  4581.         break;
  4582.     }
  4583.  
  4584.     if (pos > 0)      /* need to restore position of the handle    */
  4585.     PerlLIO_lseek(fd, pos, SEEK_SET);    /* ignore error here    */
  4586.  
  4587.     return (i);
  4588. }
  4589.  
  4590. #endif /* LOCKF_EMULATE_FLOCK */
  4591.